From 1a73baff0989dad465da8fd91f32d537bf704367 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 26 Mar 2018 16:27:40 +0000 Subject: Work in progress implementing TIP 505. --- generic/tclCmdIL.c | 17 +++-------------- generic/tclCompCmdsGR.c | 1 + tests/lreplace.test | 8 ++++---- 3 files changed, 8 insertions(+), 18 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3b2cb19..10fbd3f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2747,21 +2747,10 @@ Tcl_LreplaceObjCmd( if (first < 0) { first = 0; } - - /* - * Complain if the user asked for a start element that is greater than the - * list length. This won't ever trigger for the "end-*" case as that will - * be properly constrained by TclGetIntForIndex because we use listLen-1 - * (to allow for replacing the last elem). - */ - - if ((first >= listLen) && (listLen > 0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list doesn't contain element %s", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", - NULL); - return TCL_ERROR; + if (first > listLen) { + first = listLen; } + if (last >= listLen) { last = listLen - 1; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 396947c..ce324c8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1478,6 +1478,7 @@ TclCompileLreplaceCmd( if (parsePtr->numWords < 4) { return TCL_ERROR; } +return TCL_ERROR; listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); diff --git a/tests/lreplace.test b/tests/lreplace.test index 4a6b853..fd2f7f8 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -100,10 +100,10 @@ test lreplace-1.26 {lreplace command} { } {a {} {}} test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 -} -returnCodes 1 -result {list doesn't contain element 1} +} -result x test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y -} -returnCodes 1 -result {list doesn't contain element 1} +} -result {x y} test lreplace-1.29 {lreplace command} -body { lreplace x 1 1 [error foo] } -returnCodes 1 -result {foo} @@ -128,10 +128,10 @@ test lreplace-2.5 {lreplace errors} { } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg -} {1 {list doesn't contain element 3}} +} {0 x} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 2 2} msg] $msg -} {1 {list doesn't contain element 2}} +} {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { -- cgit v0.12 From 843d29b4486fa92657c326b43383a8e7e860fdf3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 26 Mar 2018 18:59:00 +0000 Subject: Rest of TIP 505 implementation -- mostly undoing dumb things. --- generic/tclCompCmdsGR.c | 60 ++++--------------------------------------------- 1 file changed, 4 insertions(+), 56 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ce324c8..1094352 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1472,13 +1472,12 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - int idx1, idx2, i, offset, offset2; + int idx1, idx2, i; int emptyPrefix=1, suffixStart = 0; if (parsePtr->numWords < 4) { return TCL_ERROR; } -return TCL_ERROR; listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); @@ -1494,23 +1493,6 @@ return TCL_ERROR; } /* - * idx1, idx2 are the conventional encoded forms of the tokens parsed - * as all forms of index values. Values of idx1 that come before the - * list are treated the same as if they were the start of the list. - * Values of idx2 that come after the list are treated the same as if - * they were the end of the list. - */ - - if (idx1 == TCL_INDEX_AFTER) { - /* - * [lreplace] treats idx1 value end+1 differently from end+2, etc. - * The operand encoding cannot distinguish them, so we must bail - * out to direct evaluation. - */ - return TCL_ERROR; - } - - /* * General structure of the [lreplace] result is * prefix replacement suffix * In a few cases we can predict various parts will be empty and @@ -1521,7 +1503,9 @@ return TCL_ERROR; * we must defer to direct evaluation. */ - if (idx2 == TCL_INDEX_BEFORE) { + if (idx1 == TCL_INDEX_AFTER) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_BEFORE) { suffixStart = idx1; } else if (idx2 == TCL_INDEX_END) { suffixStart = TCL_INDEX_AFTER; @@ -1553,42 +1537,6 @@ return TCL_ERROR; emptyPrefix = 0; } - /* - * [lreplace] raises an error when idx1 points after the list, but - * only when the list is not empty. This is maximum stupidity. - * - * TODO: TIP this nonsense away! - */ - if (idx1 >= TCL_INDEX_START) { - if (emptyPrefix) { - TclEmitOpcode( INST_DUP, envPtr); - } else { - TclEmitInstInt4( INST_OVER, 1, envPtr); - } - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - - /* List is not empty */ - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1), - NULL), envPtr); - TclEmitOpcode( INST_GT, envPtr); - offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - - /* Idx1 >= list length ===> raise an error */ - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( - "list doesn't contain element %d", idx1), NULL), envPtr); - CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, - Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, - envPtr->codeStart + offset + 1); - TclEmitOpcode( INST_POP, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, - envPtr->codeStart + offset2 + 1); - } - if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] -- cgit v0.12 -- cgit v0.12 From 45f91441a5885c285f3ce537e1f11b0bdbe8ac2a Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:03:58 +0000 Subject: Adjust whitespace to Tcl 8+4 tab convention. --- library/http/http.tcl | 100 +++++++++++++++++++++++++------------------------- 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 9f5310b..d897fce 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -32,14 +32,14 @@ namespace eval http { # ::tcl_platform(osVersion). if {[interp issafe]} { set http(-useragent) "Mozilla/5.0\ - (Windows; U;\ - Windows NT 10.0)\ - http/[package provide http] Tcl/[package provide Tcl]" + (Windows; U;\ + Windows NT 10.0)\ + http/[package provide http] Tcl/[package provide Tcl]" } else { set http(-useragent) "Mozilla/5.0\ - ([string totitle $::tcl_platform(platform)]; U;\ - $::tcl_platform(os) $::tcl_platform(osVersion))\ - http/[package provide http] Tcl/[package provide Tcl]" + ([string totitle $::tcl_platform(platform)]; U;\ + $::tcl_platform(os) $::tcl_platform(osVersion))\ + http/[package provide http] Tcl/[package provide Tcl]" } } @@ -211,7 +211,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { || ([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ($state(connection) eq "close")) } { - CloseSocket $state(sock) $token + CloseSocket $state(sock) $token } if {[info exists state(after)]} { after cancel $state(after) @@ -238,22 +238,22 @@ proc ::http::CloseSocket {s {token {}}} { catch {fileevent $s readable {}} set conn_id {} if {$token ne ""} { - variable $token - upvar 0 $token state - if {[info exists state(socketinfo)]} { + variable $token + upvar 0 $token state + if {[info exists state(socketinfo)]} { set conn_id $state(socketinfo) - } + } } else { - set map [array get socketmap] - set ndx [lsearch -exact $map $s] - if {$ndx != -1} { + set map [array get socketmap] + set ndx [lsearch -exact $map $s] + if {$ndx != -1} { incr ndx -1 set conn_id [lindex $map $ndx] - } + } } if {$conn_id eq {} || ![info exists socketmap($conn_id)]} { - Log "Closing socket $s (no connection info)" - if {[catch {close $s} err]} { + Log "Closing socket $s (no connection info)" + if {[catch {close $s} err]} { Log "Error: $err" } } else { @@ -602,7 +602,7 @@ proc http::geturl {url args} { if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } - if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { + if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { # something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an @@ -612,13 +612,13 @@ proc http::geturl {url args} { Finish $token "" 1 cleanup $token return -code error $sock - } + } } set state(sock) $sock Log "Using $sock for $state(socketinfo)" \ - [expr {$state(-keepalive)?"keepalive":""}] + [expr {$state(-keepalive)?"keepalive":""}] if {$state(-keepalive)} { - set socketmap($state(socketinfo)) $sock + set socketmap($state(socketinfo)) $sock } if {![info exists phost]} { @@ -731,16 +731,16 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {$state(-protocol) == 1.0 && $state(-keepalive)} { + if {$state(-protocol) == 1.0 && $state(-keepalive)} { puts $sock "Connection: keep-alive" - } - if {$state(-protocol) > 1.0 && !$state(-keepalive)} { + } + if {$state(-protocol) > 1.0 && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 - } - if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { + } + if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { puts $sock "Proxy-Connection: Keep-Alive" - } - set accept_encoding_seen 0 + } + set accept_encoding_seen 0 set content_type_seen 0 dict for {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] @@ -770,9 +770,9 @@ proc http::Connected {token proto phost srvurl} { if {!$accept_types_seen} { puts $sock "Accept: $state(accept-types)" } - if {!$accept_encoding_seen && ![info exists state(-handler)]} { + if {!$accept_encoding_seen && ![info exists state(-handler)]} { puts $sock "Accept-Encoding: gzip,deflate,compress" - } + } if {$isQueryChannel && $state(querylength) == 0} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us @@ -1548,31 +1548,31 @@ proc http::ContentEncoding {token} { proc http::make-transformation-chunked {chan command} { set lambda {{chan command} { - set data "" - set size -1 - yield - while {1} { - chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } - chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } - set chunk "" - while {$size && ![chan eof $chan]} { - set part [chan read $chan $size] - incr size -[string length $part] - append chunk $part - } - if {[catch { + set data "" + set size -1 + yield + while {1} { + chan configure $chan -translation {crlf binary} + while {[gets $chan line] < 1} { yield } + chan configure $chan -translation {binary binary} + if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } + set chunk "" + while {$size && ![chan eof $chan]} { + set part [chan read $chan $size] + incr size -[string length $part] + append chunk $part + } + if {[catch { uplevel #0 [linsert $command end $chunk] }]} { http::Log "Error in callback: $::errorInfo" } - if {[string length $chunk] == 0} { + if {[string length $chunk] == 0} { # channel might have been closed in the callback - catch {chan event $chan readable {}} - return - } - } + catch {chan event $chan readable {}} + return + } + } }} coroutine dechunk$chan ::apply $lambda $chan $command chan event $chan readable [namespace origin dechunk$chan] -- cgit v0.12 From 0a9706f48fcc2f0a675701d6d5097e08501d334e Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:05:42 +0000 Subject: Adjust to 80 columns except one 82-column line which would be less intelligible. --- library/http/http.tcl | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index d897fce..6abd223 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -25,9 +25,9 @@ namespace eval http { -proxyfilter http::ProxyRequired -urlencoding utf-8 } - # We need a useragent string of this style or various servers will refuse to - # send us compressed content even when we ask for it. This follows the - # de-facto layout of user-agent strings in current browsers. + # We need a useragent string of this style or various servers will + # refuse to send us compressed content even when we ask for it. This + # follows the de-facto layout of user-agent strings in current browsers. # Safe interpreters do not have ::tcl_platform(os) or # ::tcl_platform(osVersion). if {[interp issafe]} { @@ -1026,7 +1026,9 @@ proc http::Event {sock token} { } elseif {$n == 0} { # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { + if { ($state(http) == "") + || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) + } { set state(state) "connecting" return } @@ -1369,8 +1371,8 @@ proc http::Eof {token {force 0}} { if {!$state(binary)} { # If we are getting text, set the incoming channel's encoding - # correctly. iso8859-1 is the RFC default, but this could be any IANA - # charset. However, we only know how to convert what we have + # correctly. iso8859-1 is the RFC default, but this could be any + # IANA charset. However, we only know how to convert what we have # encodings for. set enc [CharsetToEncoding $state(charset)] @@ -1538,7 +1540,8 @@ proc http::ContentEncoding {token} { compress - x-compress { lappend r decompress } identity {} default { - return -code error "unsupported content-encoding \"$coding\"" + set msg "unsupported content-encoding \"$coding\"" + return -code error $msg } } } @@ -1555,7 +1558,9 @@ proc http::make-transformation-chunked {chan command} { chan configure $chan -translation {crlf binary} while {[gets $chan line] < 1} { yield } chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } + if {[scan $line %x size] != 1} { + return -code error "invalid size: \"$line\"" + } set chunk "" while {$size && ![chan eof $chan]} { set part [chan read $chan $size] -- cgit v0.12 From d88d33f74d687fe01610c0d278a4ce228898c7f5 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:07:05 +0000 Subject: Give all procs an explicit return, except where commented as "Implicit Return". --- library/http/http.tcl | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 6abd223..db3c044 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -68,6 +68,7 @@ namespace eval http { } } array set socketmap {} + return } init @@ -123,6 +124,7 @@ if {[info command http::Log] eq {}} {proc http::Log {args} {}} proc http::register {proto port command} { variable urlTypes set urlTypes([string tolower $proto]) [list $port $command] + # N.B. Implicit Return. } # http::unregister -- @@ -180,6 +182,7 @@ proc http::config {args} { } set http($flag) $value } + return } } @@ -224,6 +227,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(status) error } } + return } # http::CloseSocket - @@ -267,6 +271,7 @@ proc ::http::CloseSocket {s {token {}}} { Log "Cannot close connection $conn_id - no socket in socket map" } } + return } # http::reset -- @@ -292,6 +297,7 @@ proc http::reset {token {why reset}} { unset state eval ::error $errorlist } + return } # http::geturl -- @@ -827,6 +833,7 @@ proc http::Connected {token proto phost srvurl} { Finish $token $err } } + return } # Data access functions: @@ -897,6 +904,7 @@ proc http::cleanup {token} { if {[info exists state]} { unset state } + return } # http::Connect @@ -987,6 +995,7 @@ proc http::Write {token} { eval $state(-queryprogress) \ [list $token $state(querylength) $state(queryoffset)] } + return } # http::Event @@ -1192,8 +1201,8 @@ proc http::Event {sock token} { # open connection closed on a token that has been cleaned up. CloseSocket $sock } - return } + return } # http::IsBinaryContentType -- @@ -1278,6 +1287,7 @@ proc http::CopyStart {sock token {initial 1}} { Finish $token $err } } + return } proc http::CopyChunk {token chunk} { @@ -1307,6 +1317,7 @@ proc http::CopyChunk {token chunk} { } Eof $token ;# FIX ME: pipelining. } + return } # http::CopyDone @@ -1337,6 +1348,7 @@ proc http::CopyDone {token count {error {}}} { } else { CopyStart $sock $token 0 } + return } # http::Eof @@ -1385,6 +1397,7 @@ proc http::Eof {token {force 0}} { } } Finish $token + return } # http::wait -- @@ -1487,6 +1500,7 @@ proc http::ProxyRequired {host} { } return [list $http(-proxyhost) $http(-proxyport)] } + return } # http::CharsetToEncoding -- -- cgit v0.12 From 97721e9675b4ddd37cd3d9a8ad151961e778fee3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:08:19 +0000 Subject: Add parentheses to some "if" tests; transform one test without changing its outcome. --- library/http/http.tcl | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index db3c044..16e0c19 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -209,7 +209,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(error) [list $errormsg $errorInfo $errorCode] set state(status) "error" } - if { ($state(status) eq "timeout") + if { ($state(status) eq "timeout") || ($state(status) eq "error") || ([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ($state(connection) eq "close")) @@ -219,8 +219,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if {[info exists state(after)]} { after cancel $state(after) } - if {[info exists state(-command)] && !$skipCB - && ![info exists state(done-command-cb)]} { + if {[info exists state(-command)] && (!$skipCB) + && (![info exists state(done-command-cb)])} { set state(done-command-cb) yes if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} { set state(error) [list $err $errorInfo $errorCode] @@ -715,7 +715,7 @@ proc http::Connected {token proto phost srvurl} { fconfigure $state(-querychannel) -blocking 1 -translation binary set contDone 0 } - if {[info exists state(-method)] && $state(-method) ne ""} { + if {[info exists state(-method)] && ($state(-method) ne "")} { set how $state(-method) } # We cannot handle chunked encodings with -handler, so force HTTP/1.0 @@ -737,10 +737,10 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {$state(-protocol) == 1.0 && $state(-keepalive)} { + if {($state(-protocol) == 1.0) && $state(-keepalive)} { puts $sock "Connection: keep-alive" } - if {$state(-protocol) > 1.0 && !$state(-keepalive)} { + if {($state(-protocol) > 1.0) && !$state(-keepalive)} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 } if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { @@ -779,7 +779,7 @@ proc http::Connected {token proto phost srvurl} { if {!$accept_encoding_seen && ![info exists state(-handler)]} { puts $sock "Accept-Encoding: gzip,deflate,compress" } - if {$isQueryChannel && $state(querylength) == 0} { + if {$isQueryChannel && ($state(querylength) == 0)} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us @@ -1050,15 +1050,26 @@ proc http::Event {sock token} { return } - # For non-chunked transfer we may have no body - in this case we - # may get no further file event if the connection doesn't close - # and no more data is sent. We can tell and must finish up now - - # not later. - if { - !(([info exists state(connection)] - && ($state(connection) eq "close")) - || [info exists state(transfer)]) - && ($state(totalsize) == 0) + # - For non-chunked transfer we may have no body - in this case we + # may get no further file event if the connection doesn't close + # and no more data is sent. We can tell and must finish up now - + # not later - the alternative would be to wait until the server + # times out. + # - In this case, the server has NOT told the client it will close + # the connection, AND it has NOT indicated the resource length + # EITHER by setting the Content-Length (totalsize) OR by using + # chunked Transer-Encoding. + # - Do not worry here about the case (Connection: close) because + # the server should close the connection. + # - IF (NOT Connection: close) AND (NOT chunked encoding) AND + # (totalsize == 0). + + if { (!( [info exists state(connection)] + && ($state(connection) eq "close") + ) + ) + && (![info exists state(transfer)]) + && ($state(totalsize) == 0) } { Log "body size is 0 and no events likely - complete." Eof $token -- cgit v0.12 From 58eff8f224ea6ee52db925d9ff2a214f271a7e50 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:10:50 +0000 Subject: Rename some variables and commands. Details in ticket 46b6edad51. --- library/http/http.tcl | 100 ++++++++++++++++++++++++++++---------------------- 1 file changed, 57 insertions(+), 43 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 16e0c19..f22dc17 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -60,14 +60,14 @@ namespace eval http { variable formMap [array get map] # Create a map for HTTP/1.1 open sockets - variable socketmap - if {[info exists socketmap]} { + variable socketMapping + if {[info exists socketMapping]} { # Close but don't remove open sockets on re-init - foreach {url sock} [array get socketmap] { + foreach {url sock} [array get socketMapping] { catch {close $sock} } } - array set socketmap {} + array set socketMapping {} return } init @@ -238,37 +238,37 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # the second section. proc ::http::CloseSocket {s {token {}}} { - variable socketmap + variable socketMapping catch {fileevent $s readable {}} - set conn_id {} + set connId {} if {$token ne ""} { variable $token upvar 0 $token state if {[info exists state(socketinfo)]} { - set conn_id $state(socketinfo) + set connId $state(socketinfo) } } else { - set map [array get socketmap] + set map [array get socketMapping] set ndx [lsearch -exact $map $s] if {$ndx != -1} { incr ndx -1 - set conn_id [lindex $map $ndx] + set connId [lindex $map $ndx] } } - if {$conn_id eq {} || ![info exists socketmap($conn_id)]} { + if {$connId eq {} || ![info exists socketMapping($connId)]} { Log "Closing socket $s (no connection info)" if {[catch {close $s} err]} { Log "Error: $err" } } else { - if {[info exists socketmap($conn_id)]} { - Log "Closing connection $conn_id (sock $socketmap($conn_id))" - if {[catch {close $socketmap($conn_id)} err]} { + if {[info exists socketMapping($connId)]} { + Log "Closing connection $connId (sock $socketMapping($connId))" + if {[catch {close $socketMapping($connId)} err]} { Log "Error: $err" } - unset socketmap($conn_id) + unset socketMapping($connId) } else { - Log "Cannot close connection $conn_id - no socket in socket map" + Log "Cannot close connection $connId - no socket in socket map" } } return @@ -588,13 +588,13 @@ proc http::geturl {url args} { # See if we are supposed to use a previously opened channel. if {$state(-keepalive)} { - variable socketmap - if {[info exists socketmap($state(socketinfo))]} { - if {[catch {fconfigure $socketmap($state(socketinfo))}]} { + variable socketMapping + if {[info exists socketMapping($state(socketinfo))]} { + if {[catch {fconfigure $socketMapping($state(socketinfo))}]} { Log "WARNING: socket for $state(socketinfo) was closed" - unset socketmap($state(socketinfo)) + unset socketMapping($state(socketinfo)) } else { - set sock $socketmap($state(socketinfo)) + set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo)" catch {fileevent $sock writable {}} catch {fileevent $sock readable {}} @@ -624,7 +624,7 @@ proc http::geturl {url args} { Log "Using $sock for $state(socketinfo)" \ [expr {$state(-keepalive)?"keepalive":""}] if {$state(-keepalive)} { - set socketmap($state(socketinfo)) $sock + set socketMapping($state(socketinfo)) $sock } if {![info exists phost]} { @@ -1024,15 +1024,18 @@ proc http::Event {sock token} { return } if {$state(state) eq "connecting"} { - if {[catch {gets $sock state(http)} n]} { - return [Finish $token $n] - } elseif {$n >= 0} { + if {[catch {gets $sock state(http)} nsl]} { + return [Finish $token $nsl] + } elseif {$nsl >= 0} { set state(state) "header" + } else { + # nsl is -1 so either fblocked (OK) or eof. + # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} n]} { - return [Finish $token $n] - } elseif {$n == 0} { + if {[catch {gets $sock line} nhl]} { + return [Finish $token $nhl] + } elseif {$nhl == 0} { # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 if { ($state(http) == "") @@ -1046,7 +1049,7 @@ proc http::Event {sock token} { # If doing a HEAD, then we won't get any body if {$state(-validate)} { - Eof $token + Eot $token return } @@ -1072,7 +1075,7 @@ proc http::Event {sock token} { && ($state(totalsize) == 0) } { Log "body size is 0 and no events likely - complete." - Eof $token + Eot $token return } @@ -1096,7 +1099,7 @@ proc http::Event {sock token} { return } } - } elseif {$n > 0} { + } elseif {$nhl > 0} { # Process header lines if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { switch -- [string tolower $key] { @@ -1144,17 +1147,17 @@ proc http::Event {sock token} { append state(transfer_final) $line } else { Log "final chunk part" - Eof $token + Eot $token } } elseif { [info exists state(transfer)] && $state(transfer) eq "chunked" } { set size 0 - set chunk [getTextLine $sock] - set n [string length $chunk] - if {[string trim $chunk] ne ""} { - scan $chunk %x size + set hexLenChunk [getTextLine $sock] + set ntl [string length $hexLenChunk] + if {[string trim $hexLenChunk] ne ""} { + scan $hexLenChunk %x size if {$size != 0} { set bl [fconfigure $sock -blocking] fconfigure $sock -blocking 1 @@ -1170,6 +1173,7 @@ proc http::Event {sock token} { } getTextLine $sock } else { + set n 0 set state(transfer_final) {} } } @@ -1190,7 +1194,7 @@ proc http::Event {sock token} { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) } { - Eof $token + Eot $token } } } err]} { @@ -1203,11 +1207,11 @@ proc http::Event {sock token} { } } - # catch as an Eof above may have closed the socket already + # catch as an Eot above may have closed the socket already if {![catch {eof $sock} eof] && $eof} { if {[info exists $token]} { set state(connection) close - Eof $token + Eot $token } else { # open connection closed on a token that has been cleaned up. CloseSocket $sock @@ -1326,7 +1330,7 @@ proc http::CopyChunk {token chunk} { foreach stream $state(zlib) { $stream close } unset state(zlib) } - Eof $token ;# FIX ME: pipelining. + Eot $token ;# FIX ME: pipelining. } return } @@ -1355,24 +1359,34 @@ proc http::CopyDone {token count {error {}}} { if {[string length $error]} { Finish $token $error } elseif {[catch {eof $sock} iseof] || $iseof} { - Eof $token + Eot $token } else { CopyStart $sock $token 0 } return } -# http::Eof +# http::Eot +# +# Called when either: +# a. An eof condition is detected on the socket. +# b. The client decides that the response is complete. +# c. The client detects an inconsistency and aborts the transaction. # -# Handle eof on the socket +# Does: +# 1. Set state(status) +# 2. Reverse any Content-Encoding +# 3. Convert charset encoding and line ends if necessary +# 4. Call http::Finish # # Arguments # token The token returned from http::geturl +# force optional, has no effect # # Side Effects # Clean up the socket -proc http::Eof {token {force 0}} { +proc http::Eot {token {force 0}} { variable $token upvar 0 $token state if {$state(state) eq "header"} { -- cgit v0.12 From 3b48db4a90ae3ec99e9c2e85d5a3610262d77707 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:12:47 +0000 Subject: Update some comments and a Log. --- library/http/http.tcl | 43 ++++++++++++++++++++++++++----------------- 1 file changed, 26 insertions(+), 17 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index f22dc17..a6977f7 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -97,7 +97,11 @@ namespace eval http { } namespace export geturl config reset wait formatQuery register unregister - # Useful, but not exported: data size status code + # Useful, but not exported: data size status code cleanup error meta ncode + # Also mapReply. + # + # Not exported, probably should be upper-case initial letter as part + # of the internals: init getTextLine make-transformation-chunked } # http::Log -- @@ -199,7 +203,7 @@ proc http::config {args} { # reported to two places. # # Side Effects: -# Closes the socket +# May close the socket. proc http::Finish {token {errormsg ""} {skipCB 0}} { variable $token @@ -235,7 +239,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # Close a socket and remove it from the persistent sockets table. If # possible an http token is included here but when we are called from a # fileevent on remote closure we need to find the correct entry - hence -# the second section. +# the "else" block of the first "if" command. proc ::http::CloseSocket {s {token {}}} { variable socketMapping @@ -600,7 +604,7 @@ proc http::geturl {url args} { catch {fileevent $sock readable {}} } } - # don't automatically close this connection socket + # Do not automatically close this connection socket. set state(connection) {} } if {![info exists sock]} { @@ -609,7 +613,7 @@ proc http::geturl {url args} { lappend sockopts -myaddr $state(-myaddr) } if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { - # something went wrong while trying to establish the connection. + # Something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an # exception from here instead. @@ -677,7 +681,7 @@ proc http::Connected {token proto phost srvurl} { variable $token upvar 0 $token state - # Set back the variables needed here + # Set back the variables needed here. set sock $state(sock) set isQueryChannel [info exists state(-querychannel)] set isQuery [info exists state(-query)] @@ -687,7 +691,7 @@ proc http::Connected {token proto phost srvurl} { set lower [string tolower $proto] set defport [lindex $urlTypes($lower) 0] - # Send data in cr-lf format, but accept any line terminators + # Send data in cr-lf format, but accept any line terminators. fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) @@ -827,8 +831,8 @@ proc http::Connected {token proto phost srvurl} { # The socket probably was never connected, or the connection dropped # later. - # if state(status) is error, it means someone's already called Finish - # to do the above-described clean up. + # if state(status) is error, it means someone's already called + # Finish to do the above-described clean up. if {$state(status) ne "error"} { Finish $token $err } @@ -838,7 +842,7 @@ proc http::Connected {token proto phost srvurl} { # Data access functions: # Data - the URL data -# Status - the transaction status: ok, reset, eof, timeout +# Status - the transaction status: ok, reset, eof, timeout, error # Code - the HTTP transaction code, e.g., 200 # Size - the size of the URL data @@ -1085,7 +1089,7 @@ proc http::Event {sock token} { if { $state(-binary) || [IsBinaryContentType $state(type)] } { - # Turn off conversions for non-text data + # Turn off conversions for non-text data. set state(binary) 1 } if {[info exists state(-channel)]} { @@ -1093,19 +1097,19 @@ proc http::Event {sock token} { fconfigure $state(-channel) -translation binary } if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies + # Initiate a sequence of background fcopies. fileevent $sock readable {} CopyStart $sock $token return } } } elseif {$nhl > 0} { - # Process header lines + # Process header lines. if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { switch -- [string tolower $key] { content-type { set state(type) [string trim [string tolower $value]] - # grab the optional charset information + # Grab the optional charset information. if {[regexp -nocase \ {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ $state(type) -> cs]} { @@ -1143,7 +1147,11 @@ proc http::Event {sock token} { set line [getTextLine $sock] set n [string length $line] if {$n > 0} { - Log "found $n bytes following final chunk" + # - HTTP trailers (late response headers) are permitted by + # Chunked Transfer-Encoding, and can be safely ignored. + # - Do not count these bytes in the total received for the + # response body. + Log "trailer of $n bytes after final chunk - token $token" append state(transfer_final) $line } else { Log "final chunk part" @@ -1255,6 +1263,7 @@ proc http::IsBinaryContentType {type} { # http::getTextLine -- # # Get one line with the stream in blocking crlf mode +# Used if Transfer-Encoding is chunked # # Arguments # sock The socket receiving input. @@ -1355,7 +1364,7 @@ proc http::CopyDone {token count {error {}}} { eval $state(-progress) \ [list $token $state(totalsize) $state(currentsize)] } - # At this point the token may have been reset + # At this point the token may have been reset. if {[string length $error]} { Finish $token $error } elseif {[catch {eof $sock} iseof] || $iseof} { @@ -1390,7 +1399,7 @@ proc http::Eot {token {force 0}} { variable $token upvar 0 $token state if {$state(state) eq "header"} { - # Premature eof + # Premature eof. set state(status) eof } else { set state(status) ok -- cgit v0.12 From 25aad1ab18e6ac7d57e72db5af7ed702e0ea1dc0 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:15:26 +0000 Subject: Update some Log calls, mainly to specify token. --- library/http/http.tcl | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index a6977f7..bfb2569 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -262,13 +262,13 @@ proc ::http::CloseSocket {s {token {}}} { if {$connId eq {} || ![info exists socketMapping($connId)]} { Log "Closing socket $s (no connection info)" if {[catch {close $s} err]} { - Log "Error: $err" + Log "Error closing socket: $err" } } else { if {[info exists socketMapping($connId)]} { Log "Closing connection $connId (sock $socketMapping($connId))" if {[catch {close $socketMapping($connId)} err]} { - Log "Error: $err" + Log "Error closing connection: $err" } unset socketMapping($connId) } else { @@ -595,11 +595,12 @@ proc http::geturl {url args} { variable socketMapping if {[info exists socketMapping($state(socketinfo))]} { if {[catch {fconfigure $socketMapping($state(socketinfo))}]} { - Log "WARNING: socket for $state(socketinfo) was closed" + Log "WARNING: socket for $state(socketinfo) was closed\ + - token $token" unset socketMapping($state(socketinfo)) } else { set sock $socketMapping($state(socketinfo)) - Log "reusing socket $sock for $state(socketinfo)" + Log "reusing socket $sock for $state(socketinfo) - token $token" catch {fileevent $sock writable {}} catch {fileevent $sock readable {}} } @@ -625,7 +626,7 @@ proc http::geturl {url args} { } } set state(sock) $sock - Log "Using $sock for $state(socketinfo)" \ + Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] if {$state(-keepalive)} { set socketMapping($state(socketinfo)) $sock @@ -1021,7 +1022,8 @@ proc http::Event {sock token} { Log "Event $sock with invalid token '$token' - remote close?" if {![eof $sock]} { if {[set d [read $sock]] ne ""} { - Log "WARNING: additional data left on closed socket" + Log "WARNING: additional data left on closed socket\ + - token $token" } } CloseSocket $sock @@ -1078,7 +1080,8 @@ proc http::Event {sock token} { && (![info exists state(transfer)]) && ($state(totalsize) == 0) } { - Log "body size is 0 and no events likely - complete." + set msg {body size is 0 and no events likely - complete} + Log "$msg - token $token" Eot $token return } @@ -1154,7 +1157,7 @@ proc http::Event {sock token} { Log "trailer of $n bytes after final chunk - token $token" append state(transfer_final) $line } else { - Log "final chunk part" + Log "final chunk part - token $token" Eot $token } } elseif { @@ -1177,7 +1180,8 @@ proc http::Event {sock token} { } if {$size != [string length $chunk]} { Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be $size" + was [string length $chunk], should be $size -\ + token $token" } getTextLine $sock } else { @@ -1186,7 +1190,9 @@ proc http::Event {sock token} { } } } else { - #Log "read non-chunk $state(currentsize) of $state(totalsize)" + set c $state(currentsize) + set t $state(totalsize) + ##Log non-chunk currentsize $c of totalsize $t - token $token set block [read $sock $state(-blocksize)] set n [string length $block] if {$n >= 0} { @@ -1329,7 +1335,7 @@ proc http::CopyChunk {token chunk} { $token $state(totalsize) $state(currentsize)] } } else { - Log "CopyChunk Finish $token" + Log "CopyChunk Finish - token $token" if {[info exists state(zlib)]} { set excess "" foreach stream $state(zlib) { @@ -1411,7 +1417,7 @@ proc http::Eot {token {force 0}} { set state(body) [zlib $coding $state(body)] } } err]} { - Log "error doing decompression: $err" + Log "error doing decompression for token $token: $err" return [Finish $token $err] } -- cgit v0.12 From 4f8b1772509919a3fae2017482774f3714a4d5b7 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:17:38 +0000 Subject: Tidying - add empty else clauses, omit :: at start of command name http::CloseSocket in proc definition, use two lines instead of "return [Finish ...]" because there is no return value! --- library/http/http.tcl | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index bfb2569..c429138 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -241,7 +241,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # fileevent on remote closure we need to find the correct entry - hence # the "else" block of the first "if" command. -proc ::http::CloseSocket {s {token {}}} { +proc http::CloseSocket {s {token {}}} { variable socketMapping catch {fileevent $s readable {}} set connId {} @@ -250,6 +250,7 @@ proc ::http::CloseSocket {s {token {}}} { upvar 0 $token state if {[info exists state(socketinfo)]} { set connId $state(socketinfo) + } else { } } else { set map [array get socketMapping] @@ -257,18 +258,21 @@ proc ::http::CloseSocket {s {token {}}} { if {$ndx != -1} { incr ndx -1 set connId [lindex $map $ndx] + } else { } } if {$connId eq {} || ![info exists socketMapping($connId)]} { Log "Closing socket $s (no connection info)" if {[catch {close $s} err]} { Log "Error closing socket: $err" + } else { } } else { if {[info exists socketMapping($connId)]} { Log "Closing connection $connId (sock $socketMapping($connId))" if {[catch {close $socketMapping($connId)} err]} { Log "Error closing connection: $err" + } else { } unset socketMapping($connId) } else { @@ -1031,7 +1035,8 @@ proc http::Event {sock token} { } if {$state(state) eq "connecting"} { if {[catch {gets $sock state(http)} nsl]} { - return [Finish $token $nsl] + Finish $token $nsl + return } elseif {$nsl >= 0} { set state(state) "header" } else { @@ -1040,7 +1045,8 @@ proc http::Event {sock token} { } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { - return [Finish $token $nhl] + Finish $token $nhl + return } elseif {$nhl == 0} { # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 @@ -1212,7 +1218,8 @@ proc http::Event {sock token} { } } } err]} { - return [Finish $token $err] + Finish $token $err + return } else { if {[info exists state(-progress)]} { eval $state(-progress) \ @@ -1418,7 +1425,8 @@ proc http::Eot {token {force 0}} { } } err]} { Log "error doing decompression for token $token: $err" - return [Finish $token $err] + Finish $token $err + return } if {!$state(binary)} { -- cgit v0.12 From a8408767a49483d5bbca7cb51addc85b0d1ee9fd Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:20:14 +0000 Subject: Add "array unset socketMapping" in http::init. The sockets are closed and therefore do not belong in socketMapping, which should be unset. --- library/http/http.tcl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index c429138..77eae1b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -62,11 +62,12 @@ namespace eval http { # Create a map for HTTP/1.1 open sockets variable socketMapping if {[info exists socketMapping]} { - # Close but don't remove open sockets on re-init + # Close open sockets on re-init foreach {url sock} [array get socketMapping] { catch {close $sock} } } + array unset socketMapping array set socketMapping {} return } -- cgit v0.12 From b00317d1742830de2509ee2020d19c46ff0dd665 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:25:14 +0000 Subject: Changes to response handling in Finish, Eot and Event. Carefully distinguish expected and premature eof. Stricter handling of errors, minor bugfixes. Details in ticket 46b6edad51. --- library/http/http.tcl | 113 ++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 104 insertions(+), 9 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 77eae1b..5b9d03a 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -216,6 +216,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } if { ($state(status) eq "timeout") || ($state(status) eq "error") + || ($state(status) eq "eof") || ([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ($state(connection) eq "close")) } { @@ -1023,6 +1024,8 @@ proc http::Event {sock token} { variable $token upvar 0 $token state + ##Log Event call - token $token + if {![info exists state]} { Log "Event $sock with invalid token '$token' - remote close?" if {![eof $sock]} { @@ -1035,20 +1038,25 @@ proc http::Event {sock token} { return } if {$state(state) eq "connecting"} { + ##Log - connecting - token $token if {[catch {gets $sock state(http)} nsl]} { Finish $token $nsl return } elseif {$nsl >= 0} { + ##Log - connecting 1 - token $token set state(state) "header" } else { + ##Log - connecting 2 - token $token # nsl is -1 so either fblocked (OK) or eof. # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { + ##Log header failed - token $token Finish $token $nhl return } elseif {$nhl == 0} { + ##Log header done - token $token # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 if { ($state(http) == "") @@ -1062,6 +1070,7 @@ proc http::Event {sock token} { # If doing a HEAD, then we won't get any body if {$state(-validate)} { + set state(state) complete Eot $token return } @@ -1089,6 +1098,7 @@ proc http::Event {sock token} { } { set msg {body size is 0 and no events likely - complete} Log "$msg - token $token" + set state(state) complete Eot $token return } @@ -1115,6 +1125,7 @@ proc http::Event {sock token} { } } elseif {$nhl > 0} { # Process header lines. + ##Log header - token $token - $line if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { switch -- [string tolower $key] { content-type { @@ -1150,12 +1161,46 @@ proc http::Event {sock token} { } } else { # Now reading body + ##Log body - token $token if {[catch { if {[info exists state(-handler)]} { set n [eval $state(-handler) [list $sock $token]] + ##Log handler $n - token $token + # N.B. the protocol has been set to 1.0 because the -handler + # logic is not expected to handle chunked encoding. + # FIXME allow -handler with 1.1 on dechunked stacked channel. + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection - i.e. eof is not an error. + set state(state) complete + } + if {![string is integer -strict $n]} { + if 1 { + # Do not tolerate bad -handler - fail with error status. + set msg {the -handler command for http::geturl must\ + return an integer (the number of bytes read)} + Eot $token $msg + } else { + # Tolerate the bad -handler, and continue. The penalty: + # (a) Because the handler returns nonsense, we know the + # transfer is complete only when the server closes + # the connection - i.e. eof is not an error. + # (b) http::size will not be accurate. + # (c) The transaction is already downgraded to 1.0 to + # avoid chunked transfer encoding. It MUST also be + # forced to "Connection: close" or the HTTP/1.0 + # equivalent; or it MUST fail (as above) if the + # server sends "Connection: keep-alive" or the + # HTTP/1.0 equivalent. + set n 0 + set state(state) complete + } + } else { + } } elseif {[info exists state(transfer_final)]} { set line [getTextLine $sock] set n [string length $line] + set state(state) complete if {$n > 0} { # - HTTP trailers (late response headers) are permitted by # Chunked Transfer-Encoding, and can be safely ignored. @@ -1163,20 +1208,22 @@ proc http::Event {sock token} { # response body. Log "trailer of $n bytes after final chunk - token $token" append state(transfer_final) $line + set n 0 } else { Log "final chunk part - token $token" Eot $token } - } elseif { - [info exists state(transfer)] - && $state(transfer) eq "chunked" + } elseif { [info exists state(transfer)] + && ($state(transfer) eq "chunked") } { + ##Log chunked - token $token set size 0 set hexLenChunk [getTextLine $sock] - set ntl [string length $hexLenChunk] + #set ntl [string length $hexLenChunk] if {[string trim $hexLenChunk] ne ""} { scan $hexLenChunk %x size if {$size != 0} { + ##Log chunk-measure $size - token $token set bl [fconfigure $sock -blocking] fconfigure $sock -blocking 1 set chunk [read $sock $size] @@ -1184,19 +1231,39 @@ proc http::Event {sock token} { set n [string length $chunk] if {$n >= 0} { append state(body) $chunk + incr state(log_size) [string length $chunk] + ##Log chunk $n cumul $state(log_size) - token $token } if {$size != [string length $chunk]} { Log "WARNING: mis-sized chunk:\ was [string length $chunk], should be $size -\ token $token" + set n 0 + set state(connection) close + set msg {error in chunked encoding - fetch\ + terminated} + Eot $token $msg } + # CRLF that follows chunk: getTextLine $sock } else { set n 0 set state(transfer_final) {} } + } else { + # Line expected to hold chunk length is empty. + ##Log bad-chunk-measure - token $token + set n 0 + set state(connection) close + Eot $token {error in chunked encoding - fetch terminated} } } else { + ##Log unchunked - token $token + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection. + set state(state) complete + } set c $state(currentsize) set t $state(totalsize) ##Log non-chunk currentsize $c of totalsize $t - token $token @@ -1204,17 +1271,24 @@ proc http::Event {sock token} { set n [string length $block] if {$n >= 0} { append state(body) $block + ##Log non-chunk [string length $state(body)] - token $token } } + # This calculation uses n from the -handler, chunked, or unchunked + # case as appropriate. if {[info exists state]} { if {$n >= 0} { incr state(currentsize) $n + set c $state(currentsize) + set t $state(totalsize) + ##Log chunk $n currentsize $c totalsize $t - token $token } # If Content-Length - check for end of data. if { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) } { + set state(state) complete Eot $token } } @@ -1230,10 +1304,21 @@ proc http::Event {sock token} { } # catch as an Eot above may have closed the socket already + # $state(state) may be connecting, header, body, or complete if {![catch {eof $sock} eof] && $eof} { + ##Log eof - token $token if {[info exists $token]} { set state(connection) close - Eot $token + if {$state(state) eq "complete"} { + # This includes all cases in which the transaction + # can be completed by eof. + # The value "complete" is set only in http::Event, and it is + # used only in the test above. + Eot $token + } else { + # Premature eof. + Eot $token eof + } } else { # open connection closed on a token that has been cleaned up. CloseSocket $sock @@ -1404,18 +1489,28 @@ proc http::CopyDone {token count {error {}}} { # # Arguments # token The token returned from http::geturl -# force optional, has no effect +# force (previously) optional, has no effect +# reason - "eof" means premature EOF (not EOF as the natural end of +# the response) +# - "" means completion of response, with or without EOF +# - anything else describes an error confition other than +# premature EOF. # # Side Effects # Clean up the socket -proc http::Eot {token {force 0}} { +proc http::Eot {token {reason {}}} { variable $token upvar 0 $token state - if {$state(state) eq "header"} { + if {$reason eq "eof"} { # Premature eof. set state(status) eof + set reason {} + } elseif {$reason ne ""} { + # Abort the transaction. + set state(status) $reason } else { + # The response is complete. set state(status) ok } @@ -1445,7 +1540,7 @@ proc http::Eot {token {force 0}} { set state(body) [string map {\r\n \n \r \n} $state(body)] } } - Finish $token + Finish $token $reason return } -- cgit v0.12 From 767cf6314a06f14d275746f66df21ef6ee324715 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:29:43 +0000 Subject: Workaround for bug with https and unchunked response. A [read] does not deliver until the server closes the socket. The workaround is to specify the buffer size as the precise length required. --- library/http/http.tcl | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 5b9d03a..d67e217 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1263,11 +1263,23 @@ proc http::Event {sock token} { # We know the transfer is complete only when the server # closes the connection. set state(state) complete + set reqSize $state(-blocksize) + } else { + # Ask for the whole of the unserved response-body. + # This works around a problem with a tls::socket - for https + # in keep-alive mode, and a request for $state(-blocksize) + # bytes, the last part of the resource does not get read + # until the server times out. + set reqSize [expr {$state(totalsize) - $state(currentsize)}] + + # The workaround fails if reqSize is + # capped at $state(-blocksize). + # set reqSize [expr {min($reqSize, $state(-blocksize))}] } set c $state(currentsize) set t $state(totalsize) ##Log non-chunk currentsize $c of totalsize $t - token $token - set block [read $sock $state(-blocksize)] + set block [read $sock $reqSize] set n [string length $block] if {$n >= 0} { append state(body) $block @@ -1404,6 +1416,10 @@ proc http::CopyStart {sock token {initial 1}} { } } if {[catch { + # FIXME Keep-Alive on https tls::socket with unchunked transfer + # hangs until the server times out. A workaround is possible, as for + # the case without -channel, but it does not use the neat "fcopy" + # solution. fcopy $sock $state(-channel) -size $state(-blocksize) -command \ [list http::CopyDone $token] } err]} { -- cgit v0.12 From 731f40c6d954e4bb641cb336383eb4ea5d204b92 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:32:37 +0000 Subject: New http::config option -zip to control whether to send an "Accept-Encoding" request-header for a zipped response. Default true for backward compatibility. --- library/http/http.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index d67e217..9069291 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -24,6 +24,7 @@ namespace eval http { -proxyport {} -proxyfilter http::ProxyRequired -urlencoding utf-8 + -zip 1 } # We need a useragent string of this style or various servers will # refuse to send us compressed content even when we ask for it. This @@ -787,7 +788,10 @@ proc http::Connected {token proto phost srvurl} { if {!$accept_types_seen} { puts $sock "Accept: $state(accept-types)" } - if {!$accept_encoding_seen && ![info exists state(-handler)]} { + if { (!$accept_encoding_seen) + && (![info exists state(-handler)]) + && $http(-zip) + } { puts $sock "Accept-Encoding: gzip,deflate,compress" } if {$isQueryChannel && ($state(querylength) == 0)} { -- cgit v0.12 From e80e2146736e8176a0364b03fd8ad0fefe92e8d6 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:37:06 +0000 Subject: BUGFIX. Send "Connection: keep-alive" even if HTTP/1.1. Some servers (including Apache 2.2 on RHEL6) use the discretion granted by RFCs and will close the connection unless this header is sent. --- library/http/http.tcl | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 9069291..485498a 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -749,7 +749,9 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Host: $host:$port" } puts $sock "User-Agent: $http(-useragent)" - if {($state(-protocol) == 1.0) && $state(-keepalive)} { + if {($state(-protocol) >= 1.0) && $state(-keepalive)} { + # Send this header, because a 1.1 server is not compelled to treat + # this as the default. puts $sock "Connection: keep-alive" } if {($state(-protocol) > 1.0) && !$state(-keepalive)} { -- cgit v0.12 From f35c0dc2edcc96ff38d150cd621cea7b771c9a4c Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:49:13 +0000 Subject: Revise tests/http11.test for use with commits from 78b23edb6b onwards. Adjust proc "handler" to conform to http(n) --- tests/http11.test | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/tests/http11.test b/tests/http11.test index c9ded0b..8483aa3 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -515,10 +515,7 @@ proc handler {var sock token} { set chunk [read $sock] append data $chunk #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" - if {[eof $sock]} { - #::http::Log "handler eof $sock" - chan event $sock readable {} - } + return [string length $chunk] } test http11-3.0 "-handler,close,identity" -setup { -- cgit v0.12 From e9bb0992b0f392798d2d978f2bdcbc62aa6ea602 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:52:40 +0000 Subject: First step for implementing concurrent requests using the same connection. Define namespace variables socket* and http where they will (eventually) be used. Leave them unused except in http::init where they are initialised. --- library/http/http.tcl | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/library/http/http.tcl b/library/http/http.tcl index 485498a..8b4d714 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -62,14 +62,35 @@ namespace eval http { # Create a map for HTTP/1.1 open sockets variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd if {[info exists socketMapping]} { # Close open sockets on re-init foreach {url sock} [array get socketMapping] { catch {close $sock} } } + + # Traces on "unset socketRdState(*)" will cancel any queued responses. + # Traces on "unset socketWrState(*)" will cancel any queued requests. array unset socketMapping + array unset socketRdState + array unset socketWrState + array unset socketRdQueue + array unset socketWrQueue + array unset socketClosing + array unset socketPlayCmd array set socketMapping {} + array set socketRdState {} + array set socketWrState {} + array set socketRdQueue {} + array set socketWrQueue {} + array set socketClosing {} + array set socketPlayCmd {} return } init @@ -208,6 +229,14 @@ proc http::config {args} { # May close the socket. proc http::Finish {token {errormsg ""} {skipCB 0}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + variable $token upvar 0 $token state global errorInfo errorCode @@ -246,6 +275,13 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { proc http::CloseSocket {s {token {}}} { variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + catch {fileevent $s readable {}} set connId {} if {$token ne ""} { @@ -600,6 +636,13 @@ proc http::geturl {url args} { # See if we are supposed to use a previously opened channel. if {$state(-keepalive)} { variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + if {[info exists socketMapping($state(socketinfo))]} { if {[catch {fconfigure $socketMapping($state(socketinfo))}]} { Log "WARNING: socket for $state(socketinfo) was closed\ @@ -685,6 +728,13 @@ proc http::geturl {url args} { proc http::Connected {token proto phost srvurl} { variable http variable urlTypes + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd variable $token upvar 0 $token state @@ -962,6 +1012,15 @@ proc http::Connect {token proto phost srvurl} { # Write the socket and handle callbacks. proc http::Write {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + variable $token upvar 0 $token state set sock $state(sock) @@ -1027,6 +1086,15 @@ proc http::Write {token} { # Read the socket and handle callbacks. proc http::Event {sock token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + variable $token upvar 0 $token state -- cgit v0.12 From 0d887fa4657702c34d0b109df9e2634a563e5178 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:55:21 +0000 Subject: Define variable tk used in Log calls for testing. --- library/http/http.tcl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/library/http/http.tcl b/library/http/http.tcl index 8b4d714..2a5bc24 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -282,6 +282,8 @@ proc http::CloseSocket {s {token {}}} { variable socketClosing variable socketPlayCmd + set tk [namespace tail $token] + catch {fileevent $s readable {}} set connId {} if {$token ne ""} { @@ -375,6 +377,7 @@ proc http::geturl {url args} { set token [namespace current]::[incr http(uid)] variable $token upvar 0 $token state + set tk [namespace tail $token] reset $token # Process command options. @@ -738,6 +741,7 @@ proc http::Connected {token proto phost srvurl} { variable $token upvar 0 $token state + set tk [namespace tail $token] # Set back the variables needed here. set sock $state(sock) @@ -988,6 +992,7 @@ proc http::cleanup {token} { proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state + set tk [namespace tail $token] set err "due to unexpected EOF" if { [eof $state(sock)] || @@ -1023,6 +1028,7 @@ proc http::Write {token} { variable $token upvar 0 $token state + set tk [namespace tail $token] set sock $state(sock) # Output a block. Tcl will buffer this if the socket blocks @@ -1097,6 +1103,7 @@ proc http::Event {sock token} { variable $token upvar 0 $token state + set tk [namespace tail $token] ##Log Event call - token $token -- cgit v0.12 From d38ae8f97463f0a3fc07324aeae3de9508dbe9cc Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 08:56:16 +0000 Subject: Adapt fconfigure -translation for two-way pipelined operation. --- library/http/http.tcl | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 2a5bc24..06f452d 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -676,8 +676,13 @@ proc http::geturl {url args} { Finish $token "" 1 cleanup $token return -code error $sock + } else { + # Initialisation of a new socket. + fconfigure $sock -translation {auto crlf} \ + -buffersize $state(-blocksize) } } + set state(sock) $sock Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] @@ -754,8 +759,11 @@ proc http::Connected {token proto phost srvurl} { set defport [lindex $urlTypes($lower) 0] # Send data in cr-lf format, but accept any line terminators. - - fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) + # Initialisation to {auto *} now done in geturl. + # We are concerned here with the request (write) not the response (read). + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list $trRead crlf] \ + -buffersize $state(-blocksize) # The following is disallowed in safe interpreters, but the socket is # already in non-blocking mode in that case. @@ -778,7 +786,9 @@ proc http::Connected {token proto phost srvurl} { set how POST # The query channel must be blocking for the async Write to # work properly. - fconfigure $state(-querychannel) -blocking 1 -translation binary + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $state(-querychannel) -blocking 1 \ + -translation [list $trRead binary] set contDone 0 } if {[info exists state(-method)] && ($state(-method) ne "")} { @@ -886,7 +896,8 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Content-Length: $state(querylength)" } puts $sock "" - fconfigure $sock -translation {auto binary} + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list $trRead binary] fileevent $sock writable [list http::Write $token] } else { puts $sock "" @@ -1185,7 +1196,8 @@ proc http::Event {sock token} { } # We have to use binary translation to count bytes properly. - fconfigure $sock -translation binary + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list binary $trWrite] if { $state(-binary) || [IsBinaryContentType $state(type)] @@ -1465,8 +1477,9 @@ proc http::IsBinaryContentType {type} { proc http::getTextLine {sock} { set tr [fconfigure $sock -translation] + lassign $tr trRead trWrite set bl [fconfigure $sock -blocking] - fconfigure $sock -translation crlf -blocking 1 + fconfigure $sock -translation [list crlf $trWrite] -blocking 1 set r [gets $sock] fconfigure $sock -translation $tr -blocking $bl return $r -- cgit v0.12 From 70af5c2b8260845974300e98c2e4c464b787d94e Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 27 Mar 2018 14:20:23 +0000 Subject: Implement queuing and pipelining for HTTP requests over a persistent connection. --- doc/http.n | 159 ++++- library/http/http.tcl | 1448 ++++++++++++++++++++++++++++++++++++++++++++-- tests/httpPipeline.test | 859 +++++++++++++++++++++++++++ tests/httpTest.tcl | 431 ++++++++++++++ tests/httpTestScript.tcl | 509 ++++++++++++++++ 5 files changed, 3356 insertions(+), 50 deletions(-) create mode 100644 tests/httpPipeline.test create mode 100644 tests/httpTest.tcl create mode 100644 tests/httpTestScript.tcl diff --git a/doc/http.n b/doc/http.n index 40ced23..2dae77e 100644 --- a/doc/http.n +++ b/doc/http.n @@ -6,14 +6,14 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "http" n 2.7 http "Tcl Bundled Packages" +.TH "http" n 2.8 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS -\fBpackage require http ?2.7?\fR +\fBpackage require http ?2.8?\fR .\" See Also -useragent option documentation in body! .sp \fB::http::config ?\fI\-option value\fR ...? @@ -49,7 +49,7 @@ http \- Client-side implementation of the HTTP/1.1 protocol .SH DESCRIPTION .PP The \fBhttp\fR package provides the client side of the HTTP/1.1 -protocol, as defined in RFC 2616. +protocol, as defined in RFC 7230 to RFC 7235, which supersede RFC 2616. The package implements the GET, POST, and HEAD operations of HTTP/1.1. It allows configuration of a proxy host to get through firewalls. The package is compatible with the \fBSafesock\fR security @@ -95,6 +95,19 @@ comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . .TP +\fB\-pipeline\fR \fIboolean\fR +. +Specifies whether HTTP/1.1 transactions on a persistent socket will be +pipelined. See the \fBPERSISTENT SOCKETS\fR section for details. The default +is 1. +.TP +\fB\-postfresh\fR \fIboolean\fR +. +Specifies whether requests that use the \fBPOST\fR method will always use a +fresh socket, overriding the \fB-keepalive\fR option of +command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. +The default is 0. +.TP \fB\-proxyhost\fR \fIhostname\fR . The name of the proxy host, if any. If this value is the @@ -116,6 +129,18 @@ an empty list. The default filter returns the values of the \fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are non-empty. .TP +\fB\-repost\fR \fIboolean\fR +. +Specifies what to do if a POST request over a persistent connection fails +because the server has half-closed the connection. If boolean \fBtrue\fR, the +request +will be automatically retried; if boolean \fBfalse\fR it will not, and the +application +that uses \fBhttp::geturl\fR is expected to seek user confirmation before +retrying the POST. The value \fBtrue\fR should be used only under certain +conditions. See the \fBPERSISTENT SOCKETS\fR section for details. The +default is 0. +.TP \fB\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with @@ -128,8 +153,22 @@ characters. .TP \fB\-useragent\fR \fIstring\fR . -The value of the User-Agent header in the HTTP request. The default is -.QW "\fBTcl http client package 2.7\fR" . +The value of the User-Agent header in the HTTP request. In an unsafe +interpreter, the default value depends upon the operating system, and +the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) +.QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.8.12 Tcl/8.6.8\fR" . +A safe interpreter cannot determine its operating system, and so the default +in a safe interpreter is to use a Windows 10 value with the current version +numbers of \fBhttp\fR and \fBTcl\fR. +.TP +\fB\-zip\fR \fIboolean\fR +. +If the value is boolean \fBtrue\fR, then by default requests will send a header +.QW "\fBAccept-Encoding: gzip,deflate,compress\fR" . +If the value is boolean \fBfalse\fR, then by default this header will not be sent. +In either case the default can be overridden for an individual request by +supplying a custom \fBAccept-Encoding\fR header in the \fB-headers\fR option +of \fBhttp::geturl\fR. The default is 1. .RE .TP \fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR? @@ -227,7 +266,7 @@ Pragma: no-cache .TP \fB\-keepalive\fR \fIboolean\fR . -If true, attempt to keep the connection open for servicing +If boolean \fBtrue\fR, attempt to keep the connection open for servicing multiple requests. Default is 0. .TP \fB\-method\fR \fItype\fR @@ -504,6 +543,14 @@ The following elements of the array are supported: .RS .TP +\fBbinary\fR +. +This is boolean \fBtrue\fR if (after decoding any compression specified +by the +.QW "Content-Encoding" +response header) the HTTP response is binary. It is boolean \fBfalse\fR +if the HTTP response is text. +.TP \fBbody\fR . The contents of the URL. This will be empty if the \fB\-channel\fR @@ -602,6 +649,106 @@ A copy of the \fBContent-Type\fR meta-data value. . The requested URL. .RE +.SH "PERSISTENT CONNECTIONS" +.PP +.SS "BASICS" +.PP +See RFC 7230 Sec 6, which supersedes RFC 2616 Sec 8.1. +.PP +A persistent connection allows multiple HTTP/1.1 transactions to be +carried over the same TCP connection. Pipelining allows a +client to make multiple requests over a persistent connection without +waiting for each response. The server sends responses in the same order +that the requests were received. +.PP +If a POST request fails to complete, typically user confirmation is +needed before sending the request again. The user may wish to verify +whether the server was modified by the failed POST request, before +sending the same request again. +.PP +A HTTP request will use a persistent socket if the call to +\fBhttp::geturl\fR has the option \fB-keepalive true\fR. It will use +pipelining where permitted if the \fBhttp::config\fR option +\fB-pipeline\fR is boolean \fBtrue\fR (its default value). +.PP +The http package maintains no more than one persistent connection to each +server (i.e. each value of +.QW "domain:port" ). +If \fBhttp::geturl\fR is called to make a request over a persistent +connection while the connection is busy with another request, the new +request will be held in a queue until the connection is free. +.PP +The http package does not support HTTP/1.0 persistent connections +controlled by the \fBKeep-Alive\fR header. +.SS "SPECIAL CASES" +.PP +This subsection discusses issues related to closure of the +persistent connection by the server, automatic retry of failed requests, +the special treatment necessary for POST requests, and the options for +dealing with these cases. +.PP +In accordance with RFC 7230, \fBhttp::geturl\fR does not pipeline +requests that use the POST method. If a POST uses a persistent +connection and is not the first request on that connection, +\fBhttp::geturl\fR waits until it has received the response for the previous +request; or (if \fBhttp::config\fR option \fB-postfresh\fR is boolean \fBtrue\fR) it +uses a new connection for each POST. +.PP +If the server is processing a number of pipelined requests, and sends a +response header +.QW "\fBConnection: close\fR" +with one of the responses (other than the last), then subsequent responses +are unfulfilled. \fBhttp::geturl\fR will send the unfulfilled requests again +over a new connection. +.PP +A difficulty arises when a HTTP client sends a request over a persistent +connection that has been idle for a while. The HTTP server may +half-close an apparently idle connection while the client is sending a +request, but before the request arrives at the server: in this case (an +.QW "asynchronous close event" ) +the request will fail. The difficulty arises because the client cannot +be certain whether the POST modified the state of the server. For HEAD or +GET requests, \fBhttp::geturl\fR opens another connection and retransmits +the failed request. However, if the request was a POST, RFC 7230 forbids +automatic retry by default, suggesting either user confirmation, or +confirmation by user-agent software that has semantic understanding of +the application. The \fBhttp::config\fR option \fB-repost\fR allows for +either possibility. +.PP +Asynchronous close events can occur only in a short interval of time. The +\fBhttp\fR package monitors each persistent connection for closure by the +server. Upon detection, the connection is also closed at the client end, +and subsequent requests will use a fresh connection. +.PP +If the \fBhttp::geturl\fR command is called with option \fB-keepalive true\fR, +then it will both try to use an existing persistent connection +(if one is available), and it will send the server a +.QW "\fBConnection: keep-alive\fR" +request header asking to keep the connection open for future requests. +.PP +The \fBhttp::config\fR options \fB-pipeline\fR, \fB-postfresh\fR, and +\fB-repost\fR relate to persistent connections. +.PP +Option \fB-pipeline\fR, if boolean \fBtrue\fR, will pipeline GET and HEAD requests +made +over a persistent connection. POST requests will not be pipelined - if the +POST is not the first transaction on the connection, its request will not +be sent until the previous response has finished. GET and HEAD requests +made after a POST will not be sent until the POST response has been +delivered, and will not be sent if the POST fails. +.PP +Option \fB-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::geturl\fR option +\fB-keepalive\fR, and always open a fresh connection for a POST request. +.PP +Option \fB-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request +that fails because it uses a persistent connection that the server has +half-closed (an +.QW "asynchronous close event" ). +Subsequent GET and HEAD requests in a failed pipeline will also be retried. +\fIThe -repost option should be used only if the application understands +that the retry is appropriate\fR - specifically, the application must know +that if the failed POST successfully modified the state of the server, a repeat POST +would have no adverse effect. .SH EXAMPLE .PP This example creates a procedure to copy a URL to a file while printing a diff --git a/library/http/http.tcl b/library/http/http.tcl index 06f452d..f4f83c6 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -20,9 +20,12 @@ namespace eval http { if {![info exists http]} { array set http { -accept */* + -pipeline 1 + -postfresh 0 -proxyhost {} -proxyport {} -proxyfilter http::ProxyRequired + -repost 0 -urlencoding utf-8 -zip 1 } @@ -220,7 +223,7 @@ proc http::config {args} { # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. -# skipCB (optional) If set, don't call the -command callback. This +# skipCB (optional) If set, don't call the -command callback. This # is useful when geturl wants to throw an exception instead # of calling the callback. That way, the same error isn't # reported to two places. @@ -240,6 +243,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { variable $token upvar 0 $token state global errorInfo errorCode + set closeQueue 0 if {$errormsg ne ""} { set state(error) [list $errormsg $errorInfo $errorCode] set state(status) "error" @@ -251,6 +255,12 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { || ([info exists state(connection)] && ($state(connection) eq "close")) } { CloseSocket $state(sock) $token + set closeQueue 1 + } elseif { + ([info exists state(-keepalive)] && $state(-keepalive)) + && ([info exists state(connection)] && ($state(connection) ne "close")) + } { + KeepSocket $token } if {[info exists state(after)]} { after cancel $state(after) @@ -263,6 +273,233 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(status) error } } + + if { $closeQueue + && [info exists state(socketinfo)] + && [info exists socketMapping($state(socketinfo))] + && ($socketMapping($state(socketinfo)) eq $state(sock)) + } { + http::CloseQueuedQueries $state(socketinfo) $token + } + + return +} + +# http::KeepSocket - +# +# Keep a socket in the persistent sockets table and connect it to its next +# queued task if possible. Otherwise leave it idle and ready for its next +# use. +# +# Arguments: +# token Connection token. + +proc http::KeepSocket {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + # Keep this socket open for another request ("Keep-Alive"). + # React if the server half-closes the socket. + # Discussion is in http::geturl. + catch {fileevent $state(sock) readable [list http::CheckEof $state(sock)]} + + # The line below should not be changed in production code. + # It is edited by the test suite. + set TEST_EOF 0 + if {$TEST_EOF} { + # ONLY for testing reaction to server eof. + # No server timeouts will be caught. + catch {fileevent $state(sock) readable {}} + } else { + # Normal operation. + # Test constraint normalEof. + } + + if { [info exists state(socketinfo)] + && [info exists socketMapping($state(socketinfo))] + } { + set connId $state(socketinfo) + # The value "Rready" is set only here. + set socketRdState($connId) Rready + + if { $state(-pipeline) + && [info exists socketRdQueue($connId)] + && [llength $socketRdQueue($connId)] + } { + # The usual case for pipelined responses - if another response is + # queued, arrange to read it. + set token3 [lindex $socketRdQueue($connId) 0] + set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end] + variable $token3 + upvar 0 $token3 state3 + set tk2 [namespace tail $token3] + + #Log pipelined, GRANT read access to $token3 in KeepSocket + set socketRdState($connId) $token3 + lassign [fconfigure $state3(sock) -translation] trRead trWrite + fconfigure $state3(sock) -translation [list auto $trWrite] \ + -buffersize $state3(-blocksize) + Log ^D$tk2 begin receiving response - token $token3 + fileevent $state3(sock) readable \ + [list http::Event $state3(sock) $token3] + #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a) + + # Other pipelined cases. + # - The test above ensures that, for the pipelined cases in the two + # tests below, the read queue is empty. + # - In those two tests, check whether the next write will be + # nonpipeline. + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "peNding") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + } { + # This case: + # - Now it the time to run the "pending" request. + # - The next token in the write queue is nonpipeline, and + # socketWrState has been marked "pending" (in + # http::NextPipelinedWrite or http::geturl) so a new pipelined + # request cannot jump the queue. + # + # Tests: + # - In this case the read queue (tested above) is empty and this + # "pending" write token is in front of the rest of the write + # queue. + # - The write state is not Wready and therefore appears to be busy, + # but because it is "pending" we know that it is reserved for the + # first item in the write queue, a non-pipelined request that is + # waiting for the read queue to empty. That has now happened: so + # give that request read and write access. + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "peNding") + + } { + # Should not come here. The second block in the previous "elseif" + # test should be tautologous (but was needed in an earlier + # implementation) and will be removed after testing. + # If we get here, the value "pending" was assigned in error. + # This error would block the queue for ever. + Log ^X$tk <<<<< Error in queueing of requests >>>>> - token $token + + } elseif { + $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + } { + # This case: + # - The next token in the write queue is nonpipeline, and + # socketWrState is Wready. Get the next event from socketWrQueue. + # Tests: + # - In this case the read state (tested above) is Rready and the + # write state (tested here) is Wready - there is no "pending" + # request. + # Code: + # - The code is the same as the code below for the nonpipelined + # case with a queued request. + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { + (!$state(-pipeline)) + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && ($state(connection) ne "close") + } { + # If not pipelined, (socketRdState eq Rready) tells us that we are + # ready for the next write - there is no need to check + # socketWrState. Write the next request, if one is waiting. + # If the next request is pipelined, it receives premature read + # access to the socket. This is not a problem. + set token3 [lindex $socketWrQueue($connId) 0] + variable $token3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (d) + + } elseif {(!$state(-pipeline))} { + set socketWrState($connId) Wready + # Rready and Wready and idle: nothing to do. + } else { + # Rready and idle: nothing to do. + } + + } else { + CloseSocket $state(sock) $token + } + return +} + +# http::CheckEof - +# +# Read from a socket and close it if eof. +# The command is bound to "fileevent readable" on an idle socket, and +# "eof" is the only event that should trigger the binding, occurring when +# the server times out and half-closes the socket. +# +# A read is necessary so that [eof] gives a meaningful result. +# Any bytes sent are junk (or a bug). + +proc http::CheckEof {sock} { + set junk [read $sock] + set n [string length $junk] + if {$n} { + Log "WARNING: $n bytes received but no HTTP request sent" + } + + if {[catch {eof $sock} res] || $res} { + # The server has half-closed the socket. + # If a new write has started, its transaction will fail and + # will then be error-handled. + CloseSocket $sock + } return } @@ -302,23 +539,85 @@ proc http::CloseSocket {s {token {}}} { } else { } } - if {$connId eq {} || ![info exists socketMapping($connId)]} { + if { ($connId ne {}) + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $s) + } { + Log "Closing connection $connId (sock $socketMapping($connId))" + if {[catch {close $socketMapping($connId)} err]} { + Log "Error closing connection: $err" + } else { + } + if {$token eq {}} { + # Cases with a non-empty token are handled by Finish, so the tokens + # are finished in connection order. + http::CloseQueuedQueries $connId $token + } else { + } + } else { Log "Closing socket $s (no connection info)" if {[catch {close $s} err]} { Log "Error closing socket: $err" } else { } + } + return +} + +# http::CloseQueuedQueries +# +# connId - identifier "domain:port" for the connection +# token - (optional) used only for logging +# +# Called from http::CloseSocket and http::Finish, after a connection is closed, +# to clear the read and write queues if this has not already been done. + +proc http::CloseQueuedQueries {connId {token {}}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + if {![info exists socketMapping($connId)]} { + # Command has already been called. + # Don't come here again - especially recursively. + return + } + + # Used only for logging. + if {$token eq {}} { + set tk {} } else { - if {[info exists socketMapping($connId)]} { - Log "Closing connection $connId (sock $socketMapping($connId))" - if {[catch {close $socketMapping($connId)} err]} { - Log "Error closing connection: $err" - } else { - } - unset socketMapping($connId) - } else { - Log "Cannot close connection $connId - no socket in socket map" - } + set tk [namespace tail $token] + } + + if { [info exists socketPlayCmd($connId)] + && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}}) + } { + set unfinished $socketPlayCmd($connId) + } else { + set unfinished {} + } + + # The trace on "unset socketRdState(*)" cancels any pipelined + # responses. + # The trace on "unset socketWrState(*)" cancels any pipelined + # requests. + unset socketMapping($connId) + unset socketRdState($connId) + unset socketWrState($connId) + unset -nocomplain socketRdQueue($connId) + unset -nocomplain socketWrQueue($connId) + unset -nocomplain socketClosing($connId) + unset -nocomplain socketPlayCmd($connId) + + if {$unfinished ne {}} { + Log ^R$tk Any unfinished transactions (excluding $token) failed \ + - token $token + {*}$unfinished } return } @@ -332,7 +631,7 @@ proc http::CloseSocket {s {token {}}} { # why Status info. # # Side Effects: -# See Finish +# See Finish proc http::reset {token {why reset}} { variable $token @@ -354,8 +653,8 @@ proc http::reset {token {why reset}} { # Establishes a connection to a remote url via http. # # Arguments: -# url The http URL to goget. -# args Option value pairs. Valid options include: +# url The http URL to goget. +# args Option value pairs. Valid options include: # -blocksize, -validate, -headers, -timeout # Results: # Returns a token for this connection. This token is the name of an @@ -375,10 +674,12 @@ proc http::geturl {url args} { set http(uid) 0 } set token [namespace current]::[incr http(uid)] + ##Log Starting http::geturl - token $token variable $token upvar 0 $token state set tk [namespace tail $token] reset $token + Log ^A$tk URL $url - token $token # Process command options. @@ -393,8 +694,9 @@ proc http::geturl {url args} { -queryprogress {} -protocol 1.1 binary 0 - state connecting + state created meta {} + method {} coding {} currentsize 0 totalsize 0 @@ -611,14 +913,7 @@ proc http::geturl {url args} { # Don't append the fragment! set state(url) $url - # If a timeout is specified we set up the after event and arrange for an - # asynchronous socket connection. - set sockopts [list -async] - if {$state(-timeout) > 0} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } # If we are using the proxy, we must pass in the full URL that includes # the server name. @@ -636,7 +931,36 @@ proc http::geturl {url args} { # c11a51c482] set state(accept-types) $http(-accept) + if {$isQuery || $isQueryChannel} { + # It's a POST. + # A client wishing to send a non-idempotent request SHOULD wait to send + # that request until it has received the response status for the + # previous request. + if {$http(-postfresh)} { + # Override -keepalive for a POST. Use a new connection, and thus + # avoid the small risk of a race against server timeout. + set state(-keepalive) 0 + } else { + # Allow -keepalive but do not -pipeline - wait for the previous + # transaction to finish. + # There is a small risk of a race against server timeout. + set state(-pipeline) 0 + } + } else { + # It's a GET or HEAD. + set state(-pipeline) $http(-pipeline) + } + # See if we are supposed to use a previously opened channel. + # - In principle, ANY call to http::geturl could use a previously opened + # channel if it is available - the "Connection: keep-alive" header is a + # request to leave the channel open AFTER completion of this call. + # - In fact, we try to use an existing channel only if -keepalive 1 -- this + # means that at most one channel is left open for each value of + # $state(socketinfo). This property simplifies the mapping of open + # channels. + set reusing 0 + set alreadyQueued 0 if {$state(-keepalive)} { variable socketMapping variable socketRdState @@ -647,20 +971,97 @@ proc http::geturl {url args} { variable socketPlayCmd if {[info exists socketMapping($state(socketinfo))]} { + # - If the connection is idle, it has a "fileevent readable" binding + # to http::CheckEof, in case the server times out and half-closes + # the socket (http::CheckEof closes the other half). + # - We leave this binding in place until just before the last + # puts+flush in http::Connected (GET/HEAD) or http::Write (POST), + # after which the HTTP response might be generated. + # - Therefore we must be prepared for full closure of the socket, + # and catch errors on any socket operation. + if {[catch {fconfigure $socketMapping($state(socketinfo))}]} { Log "WARNING: socket for $state(socketinfo) was closed\ - - token $token" + - token $token" + + # The trace on "unset socketRdState(*)" cancels any pipelined + # responses. + # The trace on "`(*)" cancels any pipelined + # requests. unset socketMapping($state(socketinfo)) + unset socketRdState($state(socketinfo)) + unset socketWrState($state(socketinfo)) + unset -nocomplain socketRdQueue($state(socketinfo)) + unset -nocomplain socketWrQueue($state(socketinfo)) + unset -nocomplain socketClosing($state(socketinfo)) + unset -nocomplain socketPlayCmd($state(socketinfo)) + + # Do not automatically close the eventual connection socket. + set state(connection) {} + } elseif { [info exists socketClosing($state(socketinfo))] + && $socketClosing($state(socketinfo)) + } { + # The server has sent a "Connection: close" header. + # Do not use the persistent socket again. + # Since we have only one persistent socket per server, and the + # old socket is not yet dead, add the request to the write queue + # of the dying socket, which will be replayed by ReplayIfClose. + set reusing 1 + set sock $socketMapping($state(socketinfo)) + Log "reusing socket $sock for $state(socketinfo) - token $token" + + # Do not automatically close this connection socket. + set state(connection) {} + set alreadyQueued 1 + lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 + lappend com3 $token + set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] } else { + # Use the persistent socket. + # The socket may not be ready to write: an earlier request might + # still be still writing (in the pipelined case) or + # writing/reading (in the nonpipeline case). This possibility + # is handled by socketWrQueue later in this command. + set reusing 1 set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" - catch {fileevent $sock writable {}} - catch {fileevent $sock readable {}} + + # Do not automatically close this connection socket. + set state(connection) {} } } - # Do not automatically close this connection socket. - set state(connection) {} } + + if {$reusing} { + # Define state(tmpState) and state(tmpOpenCmd) for use + # by http::ReplayIfDead if the persistent connection has died. + set state(tmpState) [array get state] + + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + + set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] + } + + set state(reusing) $reusing + # Excluding ReplayIfDead and the decision whether to call it, there are four + # places outside http::geturl where state(reusing) is used: + # - Connected - if reusing and not pipelined, start the state(-timeout) + # timeout (when writing). + # - DoneRequest - if reusing and pipelined, send the next pipelined write + # - Event - if reusing and pipelined, start the state(-timeout) + # timeout (when reading). + # - Event - if not reusing and pipelined, send the next pipelined + # write + + # See comments above re the start of this timeout in other cases. + if {(!$state(reusing)) && ($state(-timeout) > 0)} { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + if {![info exists sock]} { # Pass -myaddr directly to the socket command if {[info exists state(-myaddr)]} { @@ -686,14 +1087,126 @@ proc http::geturl {url args} { set state(sock) $sock Log "Using $sock for $state(socketinfo) - token $token" \ [expr {$state(-keepalive)?"keepalive":""}] - if {$state(-keepalive)} { + + if { $state(-keepalive) + && (![info exists socketMapping($state(socketinfo))]) + } { + # Freshly-opened socket that we would like to become persistent. set socketMapping($state(socketinfo)) $sock + 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 + } 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 + } + + if {![info exists socketRdQueue($state(socketinfo))]} { + set socketRdQueue($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + if {![info exists socketWrQueue($state(socketinfo))]} { + set socketWrQueue($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } } if {![info exists phost]} { set phost "" } - fileevent $sock writable [list http::Connect $token $proto $phost $srvurl] + if {$reusing} { + # For use by http::ReplayIfDead if the persistent connection has died. + # Also used by NextPipelinedWrite. + set state(tmpConnArgs) [list $proto $phost $srvurl] + } + + # The element socketWrState($connId) has a value which is either the name of + # the token that is permitted to write to the socket, or "Wready" if no + # token is permitted to write. + # + # The code that sets the value to Wready immediately calls + # http::NextPipelinedWrite, which examines socketWrQueue($connId) and + # processes the next request in the queue, if there is one. The value + # Wready is not found when the interpreter is in the event loop unless the + # socket is idle. + # + # The element socketRdState($connId) has a value which is either the name of + # the token that is permitted to read from the socket, or "Rready" if no + # token is permitted to read. + # + # The code that sets the value to Rready then examines + # socketRdQueue($connId) and processes the next request in the queue, if + # there is one. The value Rready is not found when the interpreter is in + # the event loop unless the socket is idle. + + if {$alreadyQueued} { + # A write may or may not be in progress. There is no need to set + # socketWrState to prevent another call stealing write access - all + # subsequent calls on this socket will come here because the socket + # will close after the current read, and its + # socketClosing($connId) is 1. + ##Log "HTTP request for token $token is queued" + + } elseif { $reusing + && $state(-pipeline) + && ($socketWrState($state(socketinfo)) ne "Wready") + } { + ##Log "HTTP request for token $token is queued for pipelined use" + lappend socketWrQueue($state(socketinfo)) $token + + } elseif { $reusing + && (!$state(-pipeline)) + && ($socketWrState($state(socketinfo)) ne "Wready") + } { + # A write is queued or in progress. Lappend to the write queue. + ##Log "HTTP request for token $token is queued for nonpipeline use" + lappend socketWrQueue($state(socketinfo)) $token + + } elseif { $reusing + && (!$state(-pipeline)) + && ($socketWrState($state(socketinfo)) eq "Wready") + && ($socketRdState($state(socketinfo)) ne "Rready") + } { + # A read is queued or in progress, but not a write. Cannot start the + # nonpipeline transaction, but must set socketWrState to prevent a + # pipelined request jumping the queue. + ##Log "HTTP request for token $token is queued for nonpipeline use" + #Log re-use nonpipeline, GRANT delayed write access to $token in geturl + + set socketWrState($state(socketinfo)) peNding + lappend socketWrQueue($state(socketinfo)) $token + + } else { + if {$reusing && $state(-pipeline)} { + #Log re-use pipelined, GRANT write access to $token in geturl + set socketWrState($state(socketinfo)) $token + + } elseif {$reusing} { + # Cf tests above - both are ready. + #Log re-use nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + + } else { + # (!$reusing) + } + + # All (!$reusing) cases come here, and also some $reusing cases if the + # connection is ready. + #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + # Connect does its own fconfigure. + fileevent $sock writable \ + [list http::Connect $token $proto $phost $srvurl] + } # Wait for the connection to complete. if {![info exists state(-command)]} { @@ -716,7 +1229,7 @@ proc http::geturl {url args} { return -code error $err } } - + ##Log Leaving http::geturl - token $token return $token } @@ -726,8 +1239,8 @@ proc http::geturl {url args} { # established. # # Arguments: -# token State token. -# proto What protocol (http, https, etc.) was used to connect. +# token State token. +# proto What protocol (http, https, etc.) was used to connect. # phost Are we using keep-alive? Non-empty if yes. # srvurl Service-local URL that we're requesting # Results: @@ -748,6 +1261,11 @@ proc http::Connected {token proto phost srvurl} { upvar 0 $token state set tk [namespace tail $token] + if {$state(reusing) && (!$state(-pipeline)) && ($state(-timeout) > 0)} { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + # Set back the variables needed here. set sock $state(sock) set isQueryChannel [info exists state(-querychannel)] @@ -759,7 +1277,7 @@ proc http::Connected {token proto phost srvurl} { set defport [lindex $urlTypes($lower) 0] # Send data in cr-lf format, but accept any line terminators. - # Initialisation to {auto *} now done in geturl. + # Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest. # We are concerned here with the request (write) not the response (read). lassign [fconfigure $sock -translation] trRead trWrite fconfigure $sock -translation [list $trRead crlf] \ @@ -800,7 +1318,11 @@ proc http::Connected {token proto phost srvurl} { set state(-protocol) 1.0 } set accept_types_seen 0 + + Log ^B$tk begin sending request - token $token + if {[catch { + set state(method) $how puts $sock "$how $srvurl HTTP/$state(-protocol)" if {[dict exists $state(-headers) Host]} { # Allow Host spoofing. [Bug 928154] @@ -889,6 +1411,7 @@ proc http::Connected {token proto phost srvurl} { # response. if {$isQuery || $isQueryChannel} { + # POST method. if {!$content_type_seen} { puts $sock "Content-Type: $state(-type)" } @@ -899,25 +1422,624 @@ proc http::Connected {token proto phost srvurl} { lassign [fconfigure $sock -translation] trRead trWrite fconfigure $sock -translation [list $trRead binary] fileevent $sock writable [list http::Write $token] + # The http::Write command decides when to make the socket readable, + # using the same test as the GET/HEAD case below. } else { + # GET or HEAD method. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle persistent + # socket to http::CheckEof. We can no longer treat bytes + # received as junk. The server might still time out and + # half-close the socket if it has not yet received the first + # "puts". + fileevent $sock readable {} + } puts $sock "" flush $sock - fileevent $sock readable [list http::Event $sock $token] + Log ^C$tk end sending request - token $token + # End of writing (GET/HEAD methods). The request has been sent. + + DoneRequest $token } } err]} { # The socket probably was never connected, or the connection dropped # later. + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + if {[TestForReplay $token write $err a]} { + return + } else { + Finish $token {failed to re-use socket} + } - # if state(status) is error, it means someone's already called - # Finish to do the above-described clean up. - if {$state(status) ne "error"} { + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. + } elseif {$state(status) eq ""} { + Finish $token {failed to re-use socket} + } elseif {$state(status) ne "error"} { Finish $token $err + } else { + # if state(status) is error, it means someone's already called + # Finish to do the above-described clean up. } } return } +# http::DoneRequest -- +# +# Command called when a request has been sent. It will arrange the +# next request and/or response as appropriate. + +proc http::DoneRequest {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + + # If pipelined, connect the next HTTP request to the socket. + if {$state(reusing) && $state(-pipeline)} { + # Enable next token (if any) to write. + # The value "Wready" is set only here, and + # in http::Event after reading the response-headers of a + # non-reusing transaction. + # Previous value is $token. It cannot be pending. + set socketWrState($state(socketinfo)) Wready + + # Now ready to write the next pipelined request (if any). + http::NextPipelinedWrite $token + } else { + # If pipelined, this is the first transaction on this socket. We wait + # for the response headers to discover whether the connection is + # persistent. (If this is not done and the connection is not + # persistent, we SHOULD retry and then MUST NOT pipeline before knowing + # that we have a persistent connection + # (rfc2616 8.1.2.2)). + } + + # Connect to receive the response, unless the socket is pipelined + # and another response is being sent. + # This code block is separate from the code below because there are + # cases where socketRdState already has the value $token. + if { $state(-keepalive) + && $state(-pipeline) + && [info exists socketRdState($state(socketinfo))] + && ($socketRdState($state(socketinfo)) eq "Rready") + } { + #Log pipelined, GRANT read access to $token in Connected + set socketRdState($state(socketinfo)) $token + } + + if { $state(-keepalive) + && $state(-pipeline) + && [info exists socketRdState($state(socketinfo))] + && ($socketRdState($state(socketinfo)) ne $token) + } { + # Do not read from the socket until it is ready. + ##Log "HTTP response for token $token is queued for pipelined use" + lappend socketRdQueue($state(socketinfo)) $token + } else { + # In the pipelined case, connection for reading depends on the + # value of socketRdState. + # In the nonpipeline case, connection for reading always occurs. + #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b) + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list auto $trWrite] \ + -buffersize $state(-blocksize) + Log ^D$tk begin receiving response - token $token + fileevent $sock readable [list http::Event $sock $token] + } + return +} + +# http::NextPipelinedWrite +# +# - Connecting a socket to a token for writing is done by this command and by +# command KeepSocket. +# - If another request has a pipelined write scheduled for $token's socket, +# and if the socket is ready to accept it, connect the write and update +# the queue accordingly. +# - This command is called from http::DoneRequest and http::Event, +# IF $state(-pipeline) AND (the current transfer has reached the point at +# which the socket is ready for the next request to be written). +# - This command is called when a token has write access and is pipelined and +# keep-alive, and sets socketWrState to Wready. +# - The command need not consider the case where socketWrState is set to a token +# that does not yet have write access. Such a token is waiting for Rready, +# and the assignment of the connection to the token will be done elsewhere (in +# http::KeepSocket). +# - This command cannot be called after socketWrState has been set to a +# "pending" token value (that is then overwritten by the caller), because that +# value is set by this command when it is called by an earlier token when it +# relinquishes its write access, and the pending token is always the next in +# line to write. + +proc http::NextPipelinedWrite {token} { + variable http + variable socketRdState + variable socketWrState + variable socketWrQueue + + variable $token + upvar 0 $token state + set connId $state(socketinfo) + + if { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && ([set token2 [lindex $socketWrQueue($connId) 0] + set ${token2}(-pipeline) + ] + ) + } { + # - The usual case for a pipelined connection, ready for a new request. + #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite + set conn [set ${token2}(tmpConnArgs)] + set socketWrState($connId) $token2 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] + #Log ---- $connId << conn to $token2 for HTTP request (b) + + # In the tests below, the next request will be nonpipeline. + } elseif { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![ set token3 [lindex $socketWrQueue($connId) 0] + set ${token3}(-pipeline) + ] + ) + + && [info exists socketRdState($connId)] + && ($socketRdState($connId) eq "Rready") + } { + # The case in which the next request will be non-pipelined, and the read + # and write queues is ready: which is the condition for a non-pipelined + # write. + variable $token3 + upvar 0 $token3 state3 + set conn [set ${token3}(tmpConnArgs)] + #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite + set socketRdState($connId) $token3 + set socketWrState($connId) $token3 + set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] + # Connect does its own fconfigure. + fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + + } elseif { $state(-pipeline) + && [info exists socketWrState($connId)] + && ($socketWrState($connId) eq "Wready") + + && [info exists socketWrQueue($connId)] + && [llength $socketWrQueue($connId)] + && (![set token2 [lindex $socketWrQueue($connId) 0] + set ${token2}(-pipeline) + ] + ) + } { + # - The case in which the next request will be non-pipelined, but the + # read queue is NOT ready. + # - A read is queued or in progress, but not a write. Cannot start the + # nonpipeline transaction, but must set socketWrState to prevent a new + # pipelined request (in http::geturl) jumping the queue. + # - Because socketWrState($connId) is not set to Wready, the assignment + # of the connection to $token2 will be done elsewhere - by command + # http::KeepSocket when $socketRdState($connId) is set to "Rready". + + #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. + set socketWrState($connId) peNding + + } else { + # No requests in socketWrQueue. Nothing to do. + } + + return +} + +# http::CancelReadPipeline +# +# Cancel pipelined responses on a closing "Keep-Alive" socket. +# +# - Called by a trace when the variable ::http::socketRdState($connId) is +# unset (the trace itself is automatically removed). +# - The variable relates to a Keep-Alive socket, which has been closed. +# - Cancels all pipelined responses. The requests have been sent, +# the responses have not yet been received. +# - N.B. Always delete ::http::socketRdState($connId) before deleting +# ::http::socketRdQueue($connId), or this command will do nothing. +# +# Arguments +# As for a trace command on a variable. + +proc http::CancelReadPipeline {name1 connId op} { + variable socketRdQueue + + ##Log CancelReadPipeline $name1 $connId $op + if {[info exists socketRdQueue($connId)]} { + set msg {the connection was Closed} + foreach token $socketRdQueue($connId) { + set tk [namespace tail $token] + Log ^X$tk end of response "($msg)" - token $token + set ${token}(status) eof + Finish $token ;#$msg + } + set socketRdQueue($connId) {} + } + return +} + +# http::CancelWritePipeline +# +# Cancel queued events on a closing "Keep-Alive" socket. +# +# - Called by a trace when the variable ::http::socketWrState($connId) is +# unset (the trace itself is automatically removed). +# - The variable relates to a Keep-Alive socket, which has been closed. +# - In pipelined or nonpipeline case: cancels all queued requests. The +# requests have not yet been sent, the responses are not due and have +# no data to cancel. +# - N.B. Always delete ::http::socketWrState($connId) before deleting +# ::http::socketWrQueue($connId), or this command will do nothing. +# +# Arguments +# As for a trace command on a variable. + +proc http::CancelWritePipeline {name1 connId op} { + variable socketWrQueue + + ##Log CancelWritePipeline $name1 $connId $op + if {[info exists socketWrQueue($connId)]} { + set msg {the connection was Closed} + foreach token $socketWrQueue($connId) { + set tk [namespace tail $token] + Log ^X$tk end of response "($msg)" - token $token + set ${token}(status) eof + Finish $token ;#$msg + } + set socketWrQueue($connId) {} + } + return +} + +# http::ReplayIfDead -- +# +# - A query on a re-used persistent socket failed at the earliest opportunity, +# because the socket had been closed by the server. Keep the token, tidy up, +# and try to connect on a fresh socket. +# - The connection is monitored for eof by the command http::CheckEof. Thus +# http::ReplayIfDead is needed only when a server event (half-closing an +# apparently idle connection), and a client event (sending a request) occur at +# almost the same time, and neither client nor server detects the other's +# action before performing its own (an "asynchronous close event"). +# - To simplify testing of http::ReplayIfDead, set TEST_EOF 1 in +# http::KeepSocket, and then http::ReplayIfDead will be called if http::geturl +# is called at any time after the server timeout. +# +# Arguments: +# token Connection token. +# +# Side Effects: +# Use the same token, but try to open a new socket. + +proc http::ReplayIfDead {tokenArg doing} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + variable $tokenArg + upvar 0 $tokenArg stateArg + + Log running http::ReplayIfDead for $tokenArg $doing + + # 1. Merge the tokens for transactions in flight, the read (response) queue, + # and the write (request) queue. + + set InFlightR {} + set InFlightW {} + + # Obtain the tokens for transactions in flight. + if {$stateArg(-pipeline)} { + # Two transactions may be in flight. The "read" transaction was first. + # It is unlikely that the server would close the socket if a response + # was pending; however, an earlier request (as well as the present + # request) may have been sent and ignored if the socket was half-closed + # by the server. + + if { [info exists socketRdState($stateArg(socketinfo))] + && ($socketRdState($stateArg(socketinfo)) ne "Rready") + } { + lappend InFlightR $socketRdState($stateArg(socketinfo)) + } elseif {($doing eq "read")} { + lappend InFlightR $tokenArg + } else { + } + + if { [info exists socketWrState($stateArg(socketinfo))] + && $socketWrState($stateArg(socketinfo)) ni {Wready peNding} + } { + lappend InFlightW $socketWrState($stateArg(socketinfo)) + } elseif {($doing eq "write")} { + lappend InFlightW $tokenArg + } else { + } + + # Report any inconsistency of $tokenArg with socket*state. + if { ($doing eq "read") + && [info exists socketRdState($stateArg(socketinfo))] + && ($tokenArg ne $socketRdState($stateArg(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ + ne socketRdState($stateArg(socketinfo)) \ + $socketRdState($stateArg(socketinfo)) + + } elseif { + ($doing eq "write") + && [info exists socketWrState($stateArg(socketinfo))] + && ($tokenArg ne $socketWrState($stateArg(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ + ne socketWrState($stateArg(socketinfo)) \ + $socketWrState($stateArg(socketinfo)) + } else { + } + } else { + # One transaction should be in flight. + # socketRdState, socketWrQueue are used. + # socketRdQueue should be empty. + + # Report any inconsistency of $tokenArg with socket*state. + if {$tokenArg ne $socketRdState($stateArg(socketinfo))} { + Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ + ne socketRdState($stateArg(socketinfo)) \ + $socketRdState($stateArg(socketinfo)) + } else { + } + + # Report the inconsistency that socketRdQueue is non-empty. + if { [info exists socketRdQueue($stateArg(socketinfo))] + && ($socketRdQueue($stateArg(socketinfo)) ne {}) + } { + Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ + has read queue socketRdQueue($stateArg(socketinfo)) \ + $socketRdQueue($stateArg(socketinfo)) ne {} + } else { + } + + lappend InFlightW $socketRdState($stateArg(socketinfo)) + set socketRdQueue($stateArg(socketinfo)) {} + } + + set newQueue {} + lappend newQueue {*}$InFlightR + lappend newQueue {*}$socketRdQueue($stateArg(socketinfo)) + lappend newQueue {*}$InFlightW + lappend newQueue {*}$socketWrQueue($stateArg(socketinfo)) + + + # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket. + # CloseSocket cancels file events, closes the socket, and unsets the + # socketMapping. + # Finish calls CloseSocket, if called as below. + # Don't want Eot. + # Do not change state(status). + # Want to not unset socketWrState(*). + + if {[info exists stateArg(after)]} { + after cancel $stateArg(after) + } + catch {close $stateArg(sock)} + + # The relevant element of socketMapping, socketRdState, socketWrState, + # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set to + # new values in ReplayCore. + # The trace on "unset socketRdState(*)" cancels any pipelined responses. + # It also clears socketRdQueue(*). + # Transactions, if any, that are awaiting responses cannot be completed. + # They are listed for re-sending in newQueue. + # There is no need to unset socketWrState - the write queue transactions + # have not yet been sent, nor the state(-timeout) events. + # All tokens are preserved for re-use by ReplayCore. + + unset socketRdState($stateArg(socketinfo)) + + ReplayCore $newQueue + return +} + +# http::ReplayIfClose -- +# +# A request on a socket that was previously "Connection: keep-alive" has +# received a "Connection: close" response header. The server supplies +# that response correctly, but any later requests already queued on this +# connection will be lost when the socket closes. +# +# This command takes arguments that represent the socketWrState, +# socketRdQueue and socketWrQueue for this connection. The socketRdState +# is not needed because the server responds in full to the request that +# received the "Connection: close" response header. +# +# Existing request tokens $token (::http::$n) are preserved. The caller +# will be unaware that the request was processed this way. + +proc http::ReplayIfClose {Wstate Rqueue Wqueue} { + Log running http::ReplayIfClose for $Wstate $Rqueue $Wqueue + + if {$Wstate in $Rqueue || $Wstate in $Wqueue} { + Log WARNING duplicate token in http::ReplayIfClose - token $Wstate + set Wstate Wready + } + + # 1. Create newQueue + set InFlightW {} + if {$Wstate ni {Wready peNding}} { + lappend InFlightW $Wstate + } + + set newQueue {} + lappend newQueue {*}$Rqueue + lappend newQueue {*}$InFlightW + lappend newQueue {*}$Wqueue + + # 2. Cleanup - none needed, done by the caller. + + ReplayCore $newQueue + return +} + +# http::ReplayCore -- +# +# Command to replay a list of requests, using existing connection tokens. +# +# Abstracted from http::geturl which stores extra state in state(tmp*) so +# we don't need to do the argument processing again. +# +# Arguments: +# newQueue List of connection tokens. +# +# Side Effects: +# Use existing tokens, but try to open a new socket. + +proc http::ReplayCore {newQueue} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + + if {[llength $newQueue] == 0} { + # Nothing to do. + return + } + + ##Log running ReplayCore for {*}$newQueue + set newToken [lindex $newQueue 0] + set newQueue [lrange $newQueue 1 end] + + # 3. Use newToken, and restore its values of state(*). Do not restore + # elements tmp* - we try again only once. + + set token $newToken + variable $token + upvar 0 $token state + + if {!( + [info exists state(tmpState)] + && [info exists state(tmpOpenCmd)] + && [info exists state(tmpConnArgs)] + ) + } { + Log FAILED in http::ReplayCore - NO tmp vars + Finish $token error 1 + return + } + + # Don't alter state(status) - this would trigger http::wait if it is in use. + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + foreach name [array names state] { + if {$name ne "status"} { + unset state($name) + } + } + + # Don't alter state(status). + dict unset tmpState status + array set state $tmpState + set state(reusing) 0 + + if {$state(-timeout) > 0} { + set resetCmd [list http::reset $token timeout] + set state(after) [after $state(-timeout) $resetCmd] + } + + # 4. Open a socket. + if {[catch {eval $tmpOpenCmd} sock]} { + # Something went wrong while trying to establish the connection. + Log FAILED - $tmpOpenCmd + set state(sock) $sock + Finish $token error 1 + return + } + + # 5. Configure the persistent socket data. + if {$state(-keepalive)} { + set socketMapping($state(socketinfo)) $sock + if {$state(-pipeline)} { + #Log new, init for pipelined, GRANT write acc to $token ReplayCore + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } + + if {![info exists socketRdQueue($state(socketinfo))]} { + set socketRdQueue($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + set socketRdQueue($state(socketinfo)) {} + + if {![info exists socketWrQueue($state(socketinfo))]} { + set socketWrQueue($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + set socketWrQueue($state(socketinfo)) $newQueue + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {} + } + + # 6. Configure sockets in the queue. + foreach tok $newQueue { + set ${tok}(sock) $sock + } + + # 7. Configure the socket for newToken to send a request. + set state(sock) $sock + Log "Using $sock for $state(socketinfo) - token $token" \ + [expr {$state(-keepalive)?"keepalive":""}] + + # Initialisation of a new socket. + fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) + + # Connect does its own fconfigure. + fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] + #Log ---- $sock << conn to $token for HTTP request (e) + return +} + # Data access functions: # Data - the URL data # Status - the transaction status: ok, reset, eof, timeout, error @@ -1009,8 +2131,22 @@ proc http::Connect {token proto phost srvurl} { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" } { + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + if {[TestForReplay $token write $err b]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. + } Finish $token "connect failed $err" } else { + set state(state) connecting fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl } @@ -1050,7 +2186,21 @@ proc http::Write {token} { if {[info exists state(-query)]} { # Chop up large query strings so queryprogress callback can give # smooth feedback. - + if { $state(queryoffset) + $state(-queryblocksize) + >= $state(querylength) + } { + # This will be the last puts for the request-body. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle + # persistent socket to http::CheckEof. We can no longer + # treat bytes received as junk. The server might still time + # out and half-close the socket if it has not yet received + # the first "puts". + fileevent $sock readable {} + } + } puts -nonewline $sock \ [string range $state(-query) $state(queryoffset) \ [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] @@ -1063,6 +2213,19 @@ proc http::Write {token} { # Copy blocks from the query channel set outStr [read $state(-querychannel) $state(-queryblocksize)] + if {[eof $state(-querychannel)]} { + # This will be the last puts for the request-body. + if { (![catch {fileevent $sock readable} binding]) + && ($binding eq [list http::CheckEof $sock]) + } { + # Remove the "fileevent readable" binding of an idle + # persistent socket to http::CheckEof. We can no longer + # treat bytes received as junk. The server might still time + # out and half-close the socket if it has not yet received + # the first "puts". + fileevent $sock readable {} + } + } puts -nonewline $sock $outStr incr state(queryoffset) [string length $outStr] if {[eof $state(-querychannel)]} { @@ -1076,10 +2239,14 @@ proc http::Write {token} { set state(posterror) $err set done 1 } + if {$done} { catch {flush $sock} fileevent $sock writable {} - fileevent $sock readable [list http::Event $sock $token] + Log ^C$tk end sending request - token $token + # End of writing (POST method). The request has been sent. + + DoneRequest $token } # Callback to the client after we've completely handled everything. @@ -1126,29 +2293,74 @@ proc http::Event {sock token} { - token $token" } } + Log ^X$tk end of response (token error) - token $token CloseSocket $sock return } if {$state(state) eq "connecting"} { ##Log - connecting - token $token + if { $state(reusing) + && $state(-pipeline) + && ($state(-timeout) > 0) + && (![info exists state(after)]) + } { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + if {[catch {gets $sock state(http)} nsl]} { - Finish $token $nsl - return + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. + + if {[TestForReplay $token read $nsl c]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they + # will be discarded. + } else { + Log ^X$tk end of response (error) - token $token + Finish $token $nsl + return + } } elseif {$nsl >= 0} { ##Log - connecting 1 - token $token set state(state) "header" + } elseif { [eof $sock] + && [info exists state(reusing)] + && $state(reusing) + } { + # The socket was closed at the server end, and we didn't notice. + # This is the first read - where the closure is usually first + # detected. + + if {[TestForReplay $token read {} d]} { + return + } + + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. } else { ##Log - connecting 2 - token $token - # nsl is -1 so either fblocked (OK) or eof. + # nsl is -1 so either fblocked (OK) or (eof and not reusing). # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { ##Log header failed - token $token + Log ^X$tk end of response (error) - token $token Finish $token $nhl return } elseif {$nhl == 0} { ##Log header done - token $token + Log ^E$tk end of response headers - token $token # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 if { ($state(http) == "") @@ -1158,10 +2370,89 @@ proc http::Event {sock token} { return } + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "keep-alive") + && ($state(-keepalive)) + && (!$state(reusing)) + && ($state(-pipeline)) + } { + # Response headers received for first request on a persistent + # socket. Now ready for pipelined writes (if any). + # Previous value is $token. It cannot be pending. + set socketWrState($state(socketinfo)) Wready + http::NextPipelinedWrite $token + } + + # Once a "close" has been signaled, the client MUST NOT send any + # more requests on that connection. + # + # If either the client or the server sends the "close" token in the + # Connection header, that request becomes the last one for the + # connection. + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "close") + && ($state(-keepalive)) + } { + # The server warns that it will close the socket after this + # response. + ##Log WARNING - socket will close after response for $token + # Prepare data for a call to ReplayIfClose. + if { ($socketRdQueue($state(socketinfo)) ne {}) + || ($socketWrQueue($state(socketinfo)) ne {}) + || ($socketWrState($state(socketinfo)) ni + [list Wready peNding $token]) + } { + set InFlightW $socketWrState($state(socketinfo)) + if {$InFlightW in [list Wready peNding $token]} { + set InFlightW Wready + } else { + set msg "token ${InFlightW} is InFlightW" + ##Log $msg - token $token + } + + set socketPlayCmd($state(socketinfo)) \ + [list ReplayIfClose $InFlightW \ + $socketRdQueue($state(socketinfo)) \ + $socketWrQueue($state(socketinfo))] + + # See discussion below. + foreach tokenElement $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenElement}(after)]} { + after cancel [set ${tokenElement}(after)] + } + } + + # - Clear the queues. By doing this here, the code for + # connecting the next token to the socket needs no + # modification. + # - Do not unset socketRdState and socketWrState and trigger + # their traces, because this will close the socket, which + # is still needed for the current read. + # - The only other thing that the traces would have done is + # cancel the state(after) timeout events. This is now + # done above. + # - All tokens are preserved for re-use by ReplayCore. + + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + + } else { + set socketPlayCmd($state(socketinfo)) \ + {ReplayIfClose Wready {} {}} + } + + # Do not allow further connections on this socket. + set socketClosing($state(socketinfo)) 1 + } + set state(state) body # If doing a HEAD, then we won't get any body if {$state(-validate)} { + Log ^F$tk end of response for HEAD request - token $token set state(state) complete Eot $token return @@ -1190,6 +2481,8 @@ proc http::Event {sock token} { } { set msg {body size is 0 and no events likely - complete} Log "$msg - token $token" + set msg {(length unknown, set to 0)} + Log ^F$tk end of response body {*}$msg - token $token set state(state) complete Eot $token return @@ -1272,6 +2565,7 @@ proc http::Event {sock token} { # Do not tolerate bad -handler - fail with error status. set msg {the -handler command for http::geturl must\ return an integer (the number of bytes read)} + Log ^X$tk end of response (handler error) - token $token Eot $token $msg } else { # Tolerate the bad -handler, and continue. The penalty: @@ -1303,6 +2597,7 @@ proc http::Event {sock token} { append state(transfer_final) $line set n 0 } else { + Log ^F$tk end of response body (chunked) - token $token Log "final chunk part - token $token" Eot $token } @@ -1333,6 +2628,8 @@ proc http::Event {sock token} { token $token" set n 0 set state(connection) close + Log ^X$tk end of response (chunk error) \ + - token $token set msg {error in chunked encoding - fetch\ terminated} Eot $token $msg @@ -1348,6 +2645,7 @@ proc http::Event {sock token} { ##Log bad-chunk-measure - token $token set n 0 set state(connection) close + Log ^X$tk end of response (chunk error) - token $token Eot $token {error in chunked encoding - fetch terminated} } } else { @@ -1393,11 +2691,13 @@ proc http::Event {sock token} { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) } { + Log ^F$tk end of response body (unchunked) - token $token set state(state) complete Eot $token } } } err]} { + Log ^X$tk end of response (error ${err}) - token $token Finish $token $err return } else { @@ -1419,19 +2719,77 @@ proc http::Event {sock token} { # can be completed by eof. # The value "complete" is set only in http::Event, and it is # used only in the test above. + Log ^F$tk end of response body (unchunked, eof) - token $token Eot $token } else { # Premature eof. + Log ^X$tk end of response (unexpected eof) - token $token Eot $token eof } } else { # open connection closed on a token that has been cleaned up. + Log ^X$tk end of response (token error) - token $token CloseSocket $sock } } return } +# http::TestForReplay +# +# Command called if eof is discovered when a socket is first used for a +# new transaction. Typically this occurs if a persistent socket is used +# after a period of idleness and the server has half-closed the socket. +# +# token - the connection token returned by http::geturl +# doing - "read" or "write" +# err - error message, if any +# caller - code to identify the caller - used only in logging +# +# Return Value: boolean, true iff the command calls http::ReplayIfDead. + +proc http::TestForReplay {token doing err caller} { + variable http + variable $token + upvar 0 $token state + set tk [namespace tail $token] + if {$doing eq "read"} { + set code Q + set action response + set ing reading + } else { + set code P + set action request + set ing writing + } + + if {$err eq {}} { + set err "detect eof when $ing (server timed out?)" + } + + if {$state(method) eq "POST" && !$http(-repost)} { + # No Replay. + # The present transaction will end when Finish is called. + # That call to Finish will abort any other transactions + # currently in the write queue. + # For calls from http::Event this occurs when execution + # reaches the code block at the end of that proc. + set msg {no retry for POST with http::config -repost 0} + Log reusing socket failed "($caller)" - $msg - token $token + Log error - $err - token $token + Log ^X$tk end of $action (error) - token $token + return 0 + } else { + # Replay. + set msg {try a new socket} + Log reusing socket failed "($caller)" - $msg - token $token + Log error - $err - token $token + Log ^$code$tk Any unfinished (incl this one) failed - token $token + ReplayIfDead $token $doing + return 1 + } +} + # http::IsBinaryContentType -- # # Determine if the content-type means that we should definitely transfer @@ -1475,6 +2833,8 @@ proc http::IsBinaryContentType {type} { # Results: # The line of text, without trailing newline +# FIXME get rid of blocking + proc http::getTextLine {sock} { set tr [fconfigure $sock -translation] lassign $tr trRead trWrite @@ -1662,7 +3022,7 @@ proc http::Eot {token {reason {}}} { # token Connection token. # # Results: -# The status after the wait. +# The status after the wait. proc http::wait {token} { variable $token diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test new file mode 100644 index 0000000..017661d --- /dev/null +++ b/tests/httpPipeline.test @@ -0,0 +1,859 @@ +# httpPipeline.test +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +package require http 2.8 + +set sourcedir [file normalize [file dirname [info script]]] +source [file join $sourcedir httpTest.tcl] +source [file join $sourcedir httpTestScript.tcl] + +# ------------------------------------------------------------------------------ +# (1) Define the test scripts that will be used to generate logs for analysis - +# and also define the "correct" results. +# ------------------------------------------------------------------------------ + +proc ReturnTestScriptAndResult {ca cb delay te} { + + switch -- $ca { + 1 {set start { + START + KEEPALIVE 0 + PIPELINE 0 + }} + + 2 {set start { + START + KEEPALIVE 0 + PIPELINE 1 + }} + + 3 {set start { + START + KEEPALIVE 1 + PIPELINE 0 + }} + + 4 {set start { + START + KEEPALIVE 1 + PIPELINE 1 + }} + + default { + return -code error {no matching script} + } + } + + set middle " + [list DELAY $delay] + " + + switch -- $cb { + 1 {set end { + GET a + GET b + GET c + GET a + STOP + } + set resShort {1 ? ? ?} + set resLong {1 2 3 4} + } + + 2 {set end { + GET a + HEAD b + GET c + HEAD a + HEAD c + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 3 {set end { + HEAD a + GET b + HEAD c + HEAD b + GET a + GET b + STOP + } + set resShort {1 ? ? ? ? ?} + set resLong {1 2 3 4 5 6} + } + + 4 {set end { + GET a + GET b + GET c + GET a + POST b address=home code=brief paid=yes + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 5 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 6 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 ? ? 6 7 ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 7 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 ? 4 ? ? 7 8 ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 8 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 9 {set end { + # Telling the server to close the connection. + GET a + POST b close=y address=home code=brief paid=yes + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 10 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + POST c address=home code=brief paid=yes + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 11 {set end { + # Telling the server to close the connection twice. + GET a + GET b close=y + GET c + GET a + GET b close=y + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? 6 ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 12 {set end { + # Telling the server to delay before sending the response. + GET a + GET b delay=1 + GET c + GET a + GET b + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 13 {set end { + # Making the server close the connection (time out). + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + STOP + } + set resShort {1 2 ? ? ?} + set resLong {1 2 3 4 5} + } + + 14 {set end { + # Making the server close the connection (time out) twice. + GET a + WAIT 2000 + GET b + GET c + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 15 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y delay=1 + POST c address=home code=brief paid=yes delay=1 + POST a address=home code=brief paid=yes close=y + WAIT 2000 + POST b address=home code=brief paid=yes delay=1 + POST c address=home code=brief paid=yes close=y + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 16 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 4 ? 6 7 ? 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 17 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + WAIT 2000 + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 ? 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + + 18 {set end { + REPOST 0 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + # resShort is overwritten below for the case ($te == 1). + } + + + 19 {set end { + REPOST 0 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + + 20 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 21 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + 22 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 23 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + 24 {set end { + GET a + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + + 25 {set end { + GET a + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + default { + return -code error {no matching script} + } + } + + + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result {} + append result "Passed all sanity checks.\n" + append result "Have overlaps including response body:\n" + + } else { + # Keep-Alive, pipelined: ($ca == 4) + set result {} + append result "Passed all sanity checks.\n" + append result "Overlap-free without response body:\n" + append result "$resShort" + } + + # - The special case of test *.18*-testEof needs test results to be + # individually written. + # - These test -repost 0 when there is a POST to apply it to, and the server + # timeout has not been detected. + if {($cb == 18) && ($te == 1)} { + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3 && $delay == 0} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$delay == 0} { + # Keep-Alive, pipelined: ($ca == 4) + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } else { + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } + } + + return [list "$start$middle$end" $result] +} + +# ------------------------------------------------------------------------------ +# Proc MakeMessage +# ------------------------------------------------------------------------------ +# WHD's one-line command to generate multi-line strings from readable code. +# +# Example: +# set blurb [MakeMessage { +# |This command allows multi-line strings to be created with readable +# |code, and without breaking the rules for indentation. +# | +# |The command shifts the entire block of text to the left, omitting +# |the pipe character and the spaces to its left. +# }] +# ------------------------------------------------------------------------------ + +proc MakeMessage {in} { + regsub -all -line {^\s*\|} [string trim $in] {} + # N.B. Implicit Return. +} + + +proc ReturnTestScript {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $script +} + +proc ReturnTestResult {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $result +} + + +# ------------------------------------------------------------------------------ +# (2) Command to run a test script and use httpTest to analyse the logs. +# ------------------------------------------------------------------------------ + +namespace import httpTestScript::runHttpTestScript +namespace import httpTestScript::cleanupHttpTestScript + +proc RunTest {header footer delay te} { + set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]] + set skipOverlaps 0 + set notIncluded {} + + # -------------------------------------------------------------------------- + # Custom code for specific tests + # -------------------------------------------------------------------------- + if {$header < 3} { + set skipOverlaps 1 + for {set i 1} {$i <= $num} {incr i} { + lappend notIncluded $i + } + } elseif {$header > 2 && $footer == 18 && $te == 1} { + set skipOverlaps 1 + if {$delay == 0} { + # Transaction 1 is conventional. + # Check that transactions 2,3,4 are cancelled. + set notIncluded {1} + } else { + # Transaction 1 is conventional. + # Check that transaction 2 is cancelled. + # The timing of transactions 3 and 4 is uncertain. + set notIncluded {1 3 4} + } + } elseif {$footer in {20 22 23 24 25}} { + # Transaction 2 uses its own socket. + set notIncluded 2 + } else { + } + # -------------------------------------------------------------------------- + # End of custom code for specific tests + # -------------------------------------------------------------------------- + + + set Results [httpTest::LogAnalyse $num $skipOverlaps $notIncluded $notIncluded] + lassign $Results msg cleanE cleanF dirtyE dirtyF + if {$msg eq {}} { + set msg "Passed all sanity checks." + } else { + set msg "Problems with sanity checks:\n$msg" + } + + if 0 { + puts $msg + puts "Overlap-free including response body:\n$cleanF" + puts "Have overlaps including response body:\n$dirtyF" + puts "Overlap-free without response body:\n$cleanE" + puts "Have overlaps without response body:\n$dirtyE" + } + + if {$header < 3} { + # No ordering, just check that transactions all finish + set result $msg + } elseif {$header == 3} { + # Not pipelined - check overlaps with response body. + set result "$msg\nHave overlaps including response body:\n$dirtyF" + } else { + # Pipelined - check overlaps without response body. Check that the + # first request, the first requests after replay, and POSTs are clean. + set result "$msg\nOverlap-free without response body:\n$cleanE" + } + set ::nTokens $num + return $result +} + + +# ------------------------------------------------------------------------------ +# (3) VERBOSITY CONTROL +# ------------------------------------------------------------------------------ +# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis. +# If still obscure, uncomment #Log and ##Log lines in the http package. +# ------------------------------------------------------------------------------ + +set ::httpTest::testOptions(-verbose) 0 + + +# ------------------------------------------------------------------------------ +# (4) Define the base URLs used for testing. Each must have a query string. +# ------------------------------------------------------------------------------ +# - A HTTP/1.1 server is required. It should be configured to provide +# persistent connections when requested to do so, and to close these +# connections if they are idle for one second. +# - The resource must be served with status 200 in response to a valid GET or +# POST. +# - The value of "page" is always specified in the query-string. Different +# resources for the three values of "page" allow testing of both chunked and +# unchunked transfer encoding. +# - The variables "close" and "delay" may be specified in the query-string (for +# a GET) or the request body (for a POST). +# - "delay" is a numerical value in seconds, and causes the server to delay +# the response, including headers. +# - "close", if it has the value "y", instructs the server to close the +# connection ater the current request. +# - Any other variables should be ignored. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + variable URL + array set URL { + a http://test-tcl-http.kerlin.org/index.html?page=privacy + b http://test-tcl-http.kerlin.org/index.html?page=conditions + c http://test-tcl-http.kerlin.org/index.html?page=welcome + } +} + + +# ------------------------------------------------------------------------------ +# (5) Define the tests +# ------------------------------------------------------------------------------ +# Constraints: +# - serverNeeded - the URLs defined at (4) must be available, and must have the +# properties specified there. +# - duplicate - the value of -pipeline does not matter if -keepalive 0 +# - timeout1s - tests that work correctly only if the server closes +# persistent connections after one second. +# +# Server timeout of persistent connections should be 1s. Delays of 2s are +# intended to cause timeout. +# Servers are usually configured to use a longer timeout: this will cause the +# tests to fail. The "2000" could be replaced with a larger number, but the +# tests will then be inconveniently slow. +# ------------------------------------------------------------------------------ + +#testConstraint serverNeeded 1 +#testConstraint timeout1s 1 +#testConstraint duplicate 1 + +# ------------------------------------------------------------------------------ +# Proc SetTestEof - to edit the command ::http::KeepSocket +# ------------------------------------------------------------------------------ +# The usual line in command ::http::KeepSocket is " set TEST_EOF 0". +# Whether the value set in the file is 0 or 1, change it here to the value +# specified by the argument. +# +# It is worth doing all tests for both values of the argument. +# +# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible +# and closes the connection. +# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the +# reaction to finding server eof can be tested without the difficulty +# of testing in the few milliseconds of an asynchronous close event. +# ------------------------------------------------------------------------------ + +proc SetTestEof {test} { + set body [info body ::http::KeepSocket] + set subs " set TEST_EOF $test" + set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody] + if {$count != 1} { + return -code error {proc ::http::KeepSocket has unexpected form} + } + proc ::http::KeepSocket {token} $newBody + return +} + +for {set header 1} {$header <= 4} {incr header} { + if {$header == 4} { + set ::httpTest::testOptions(-dotted) 1 + set match glob + } else { + set ::httpTest::testOptions(-dotted) 0 + set match exact + } + + if {$header == 2} { + set cons0 {serverNeeded duplicate} + } else { + set cons0 serverNeeded + } + + for {set footer 1} {$footer <= 25} {incr footer} { + foreach {delay label} { + 0 a + 1 b + 2 c + 3 d + 5 e + 8 f + 12 g + 100 h + 500 i + 2000 j + } { + foreach te {0 1} { + if {$te} { + set tag testEof + } else { + set tag normal + } + set suffix {} + set cons $cons0 + + # ------------------------------------------------------------------ + # Custom code for individual tests + # ------------------------------------------------------------------ + if {$footer in {18}} { + # Custom code: + if {($label eq "j") && ($te == 1)} { + continue + } + if {$te == 1} { + # The test (of REPOST 0) is useful if tag is "testEof" + # (server timeout without client reaction). The same test + # has a different result if tag is "normal". + + set suffix " - extra test for -repost 0 - ::http::2 must be" + append suffix " cancelled" + if {($delay == 0)} { + append suffix ", along with ::http::3 ::http::4 if" + append suffix " the test creates these before ::http::2" + append suffix " is cancelled" + } + } else { + } + } elseif {$footer in {19}} { + set suffix " - extra test for -repost 0" + } elseif {$footer in {20 21}} { + set suffix " - extra test for -postfresh 1" + if {($footer == 20)} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } + } elseif {$footer in {22 23 24 25}} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } else { + } + + if {($footer >= 13 && $footer <= 23)} { + # Test use WAIT and depend on server timeout before this time. + lappend cons timeout1s + } + # ------------------------------------------------------------------ + # End of custom code. + # ------------------------------------------------------------------ + + set name "pipeline test header $header footer $footer delay $delay $tag$suffix" + + + # Here's the test: + test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \ + -setup [string map [list TE $te] { + http::init + set http::http(uid) 0 + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + SetTestEof {TE} + }] -body [list RunTest $header $footer $delay $te] -cleanup { + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + cleanupHttpTestScript + SetTestEof 0 + set ::httpTest::testResults {} + after 2000 + # Wait for persistent sockets on the server to time out. + } -result [ReturnTestResult $header $footer $delay $te] -match $match + + + } + + } + } +} + +# ------------------------------------------------------------------------------ +# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0 +# ------------------------------------------------------------------------------ +# These tests are a bit awkward because the main test kit analyses whether all +# requests are satisfied, with retries if necessary, and it has result analysis +# for processing retry logs. +# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis +# is a one-off. +# - Tests *.18a-testEof depend on client/server timing - the test needs to call +# http::geturl for all requests before the POST (request 2) is cancelled. +# We test that requests 2, 3, 4 are all cancelled. +# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be +# added to the write queue before request 2 is completed. We simply check that +# request 2 is cancelled. +# - The behaviour is different if all connections are allowed to time out +# (label "j"). This case is not needed to test -repost 0, and is omitted. +# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no +# effect). +# ------------------------------------------------------------------------------ + + +unset header footer delay label suffix match cons name te +namespace delete ::httpTest +namespace delete ::httpTestScript + +::tcltest::cleanupTests diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl new file mode 100644 index 0000000..ad08048 --- /dev/null +++ b/tests/httpTest.tcl @@ -0,0 +1,431 @@ +# httpTest.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTest for analysis of Log output of http requests. +# ------------------------------------------------------------------------------ +# This is a specialised test kit for examining the presence, ordering, and +# overlap of multiple HTTP transactions over a persistent ("Keep-Alive") +# connection; and also for testing reconnection in accordance with RFC 7230 when +# the connection is lost. +# +# This kit is probably not useful for other purposes. It depends on the +# presence of specific Log commands in the http library, and it interprets the +# logs that these commands create. +# ------------------------------------------------------------------------------ + +package require http + +namespace eval ::http { + variable TestStartTimeInMs [clock milliseconds] +} + +namespace eval ::httpTest { + variable testResults {} + variable testOptions + array set testOptions { + -verbose 0 + -dotted 1 + } + # -verbose - 0 quiet 1 write to stderr 2 write more + # -dotted - (boolean) use dots for absences in lists of transactions +} + +proc httpTest::Puts {txt} { + variable testOptions + if {$testOptions(-verbose) > 0} { + puts stderr $txt + flush stderr + } + return +} + +# http::Log +# +# A special-purpose logger used for running tests. +# - Processes Log calls that have "^" in their arguments, and records them in +# variable ::httpTest::testResults. +# - Also writes them to stderr (using Puts) if ($testOptions(-verbose) > 0). +# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1). + +proc http::Log {args} { + variable TestStartTimeInMs + set time [expr {[clock milliseconds] - $TestStartTimeInMs}] + set txt [list $time {*}$args] + if {[string first ^ $txt] != -1} { + ::httpTest::LogRecord $txt + ::httpTest::Puts $txt + } elseif {$::httpTest::testOptions(-verbose) > 1} { + ::httpTest::Puts $txt + } + return +} + + +# Called by http::Log (the "testing" version) to record logs for later analysis. + +proc httpTest::LogRecord {txt} { + variable testResults + + set pos [string first ^ $txt] + set len [string length $txt] + if {$pos > $len - 3} { + puts stderr "Logging Error: $txt" + puts stderr "Fix this call to Log in http-*.tm so it has ^ then\ + a letter then a numeral." + flush stderr + } elseif {$pos == -1} { + # Called by mistake. + } else { + set letter [string index $txt [incr pos]] + set number [string index $txt [incr pos]] + # Max 9 requests! + lappend testResults [list $letter $number] + } + + return +} + + +# ------------------------------------------------------------------------------ +# Commands for analysing the logs recorded when calling http::geturl. +# ------------------------------------------------------------------------------ + +# httpTest::TestOverlaps -- +# +# The main test for correct behaviour of pipelined and sequential +# (non-pipelined) transactions. Other tests should be run first to detect +# any inconsistencies in the data (e.g. absence of the elements that are +# examined here). +# +# Examine the sequence $someResults for each transaction from 1 to $n, +# ignoring any that are listed in $badTrans. +# Determine whether the elements "B" to $term for one transaction overlap +# elements "B" to $term for the previous and following transactions. +# +# Transactions in the list $badTrans are not included in "clean" or +# "dirty", but their possible overlap with other transactions is noted. +# Transactions in the list $notPiped are a subset of $badTrans, and +# their possible overlap with other transactions is NOT noted. +# +# Arguments: +# someResults - list of results, each of the form {letter numeral} +# n - number of HTTP transactions +# term - letter that indicated end of search range. "E" for testing +# overlaps from start of request to end of response headers. +# "F" to extend to the end of the response body. +# msg - the cumulative message from sanity checks. Append to it only +# to report a test failure. +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $clean $dirty] +# msg - warning messages: nothing will be appended to argument $msg if there +# is an error with the test. +# clean - list of transactions that have no overlap with other transactions +# dirty - list of transactions that have YES overlap with other transactions + +proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { + variable testOptions + + # Check whether transactions overlap: + set clean {} + set dirty {} + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set myStart [lsearch -exact $someResults [list B $i]] + set myEnd [lsearch -exact $someResults [list $term $i]] + + if {($myStart == -1 || $myEnd == -1)} { + set res "Cannot find positions of transaction $i" + append msg $res \n + Puts $res + } + + set overlaps {} + for {set j $myStart} {$j <= $myEnd} {incr j} { + lassign [lindex $someResults $j] letter number + if {$number != $i && $letter ne "A" && $number ni $notPiped} { + lappend overlaps $number + } + } + + if {[llength $overlaps] == 0} { + set res "Transaction $i has no overlaps" + Puts $res + lappend clean $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend dirty . + } else { + } + } else { + set res "Transaction $i overlaps with [join $overlaps { }]" + Puts $res + lappend dirty $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend clean . + } else { + } + } + } + return [list $msg $clean $dirty] +} + +# httpTest::PipelineNext -- +# +# Test whether prevPair, pair are valid as consecutive elements of a pipelined +# sequence (Start 1), (End 1), (Start 2), (End 2) ... +# Numbers are integers increasing (by 1 if argument "any" is false), and need +# not begin with 1. +# The first element of the sequence has prevPair {} and is always passed as +# valid. +# +# Arguments; +# Start - string that labels the start of a segment +# End - string that labels the end of a segment +# prevPair - previous "pair" (list of string and number) element of a +# sequence, or {} if argument "pair" is the first in the +# sequence. +# pair - current "pair" (list of string and number) element of a +# sequence +# any - (boolean) iff true, accept any increasing sequence of integers. +# If false, integers must increase by 1. +# +# Return value - boolean, true iff the two pairs are valid consecutive elements. + +proc httpTest::PipelineNext {Start End prevPair pair any} { + if {$prevPair eq {}} { + return 1 + } + + lassign $prevPair letter number + lassign $pair newLetter newNumber + if {$letter eq $Start} { + return [expr {($newLetter eq $End) && ($newNumber == $number)}] + } elseif {$any} { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber > $number)}] + } else { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}] + } +} + +# httpTest::TestPipeline -- +# +# Given a sequence of "pair" elements, check that the elements whose string is +# $Start or $End form a valid pipeline. Ignore other elements. +# +# Return value: {} if valid pipeline, otherwise a non-empty error message. + +proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} { + set sequence {} + set prevPair {} + set ok 1 + set any [llength $badTrans] + foreach pair $someResults { + lassign $pair letter number + if {($letter in [list $Start $End]) && ($number ni $badTrans)} { + lappend sequence $pair + if {![PipelineNext $Start $End $prevPair $pair $any]} { + set ok 0 + break + } + set prevPair $pair + } + } + + if {!$ok} { + set res "$desc are not pipelined: {$sequence}" + append msg $res \n + Puts $res + } + return $msg +} + +# httpTest::TestSequence -- +# +# Examine each transaction from 1 to $n, ignoring any that are listed +# in $badTrans. +# Check that each transaction has elements A to F, in alphabetical order. + +proc httpTest::TestSequence {someResults n msg badTrans} { + variable testOptions + + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set sequence {} + foreach pair $someResults { + lassign $pair letter number + if {$number == $i} { + lappend sequence $letter + } + } + if {$sequence eq {A B C D E F}} { + } else { + set res "Wrong sequence for token ::http::$i - {$sequence}" + append msg $res \n + Puts $res + if {"X" in $sequence} { + set res "- and error(s) X" + append msg $res \n + Puts $res + } + if {"Y" in $sequence} { + set res "- and warnings(s) Y" + append msg $res \n + Puts $res + } + } + } + return $msg +} + +proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} { + variable testOptions + + # Check that stages for "good" transactions are all present and correct: + set msg [TestSequence $someResults $n $msg $badTrans] + + # Check that requests are pipelined: + set msg [TestPipeline $someResults $n B C $msg Requests $notPiped] + + # Check that responses are pipelined: + set msg [TestPipeline $someResults $n D F $msg Responses $notPiped] + + if {$skipOverlaps} { + set cleanE {} + set dirtyE {} + set cleanF {} + set dirtyF {} + } else { + Puts "Overlaps including response body (test for non-pipelined case)" + lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF + + Puts "Overlaps without response body (test for pipelined case)" + lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE + } + + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +# httpTest::ProcessRetries -- +# +# Command to examine results for socket-changing records [PQR], +# divide the results into segments for each connection, and analyse each segment +# individually. +# (Could add $sock to the logging to simplify this, but never mind.) +# +# In each segment, identify any transactions that are not included, and +# any that are aborted, to assist subsequent testing. +# +# Prepend A records (socket-independent) to each segment for transactions that +# were scheduled (by A) but not completed (by F). Pass each segment to +# MostAnalysis for processing. + +proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} { + variable testOptions + + set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] + if {$nextRetry == -1} { + return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] + } + set badTrans $notIncluded + set tryCount 0 + set try $nextRetry + incr tryCount + lassign [lindex $someResults $try] letter number + Puts "Processing retry [lindex $someResults $try]" + set beforeTry [lrange $someResults 0 $try-1] + Puts [join $beforeTry \n] + set afterTry [lrange $someResults $try+1 end] + + set dummyTry {} + for {set i 1} {$i <= $n} {incr i} { + set first [lsearch -exact $beforeTry [list A $i]] + set last [lsearch -exact $beforeTry [list F $i]] + if {$first == -1} { + set res "Transaction $i was not started in connection number $tryCount" + # append msg $res \n + Puts $res + if {$i ni $badTrans} { + lappend badTrans $i + } else { + } + } elseif {$last == -1} { + set res "Transaction $i was started but unfinished in connection number $tryCount" + # append msg $res \n + Puts $res + lappend badTrans $i + lappend dummyTry [list A $i] + } else { + set res "Transaction $i was started and finished in connection number $tryCount" + # append msg $res \n + Puts $res + lappend notIncluded $i + } + } + + # Analyse the part of the results before the first replay: + set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped] + lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1 + + # Pass the rest of the results to be processed recursively. + set afterTry [concat $dummyTry $afterTry] + set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped] + lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2 + + set cleanE [concat $cleanE1 $cleanE2] + set cleanF [concat $cleanF1 $cleanF2] + set dirtyE [concat $dirtyE1 $dirtyE2] + set dirtyF [concat $dirtyF1 $dirtyF2] + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} { + variable testResults + variable testOptions + + # Check that each data item has the correct form {letter numeral}. + set ii 0 + set ok 1 + foreach pair $testResults { + lassign $pair letter number + if { [string match {[A-Z]} $letter] + && [string match {[0-9]} $number] + } { + # OK + } else { + set ok 0 + set res "Error: testResults has bad element {$pair} at position $ii" + append msg $res \n + Puts $res + } + incr ii + } + + if {!$ok} { + return $msg + } + set msg {} + + Puts [join $testResults \n] + ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped + # N.B. Implicit Return. +} diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl new file mode 100644 index 0000000..a826c81 --- /dev/null +++ b/tests/httpTestScript.tcl @@ -0,0 +1,509 @@ +# httpTestScript.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTestScript for executing test scripts written in a convenient +# shorthand. +# ------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------ +# Documentation for "package" httpTestScript. +# ------------------------------------------------------------------------------ +# To use the package: +# (a) define URLs as the values of elements in the array ::httpTestScript +# (b) define a script in terms of the commands +# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST +# referring to URLs by the name of the corresponding array element. The +# script can include any other Tcl commands, and evaluates in the +# httpTestScript namespace. +# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script. +# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test" +# command. +# ------------------------------------------------------------------------------ +# START +# Must be the first command of the script. +# +# STOP +# Must be present in the script to avoid waiting for client timeout. +# Usually the last command, but can be elsewhere to end a script prematurely. +# Subsequent httpTestScript commands will have no effect. +# +# DELAY ms +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. +# +# KEEPALIVE +# Set the value passed to http::geturl for the -keepalive option. The command +# applies to subsequent requests in the script. Default 1. +# +# WAIT ms +# Pause for a time in ms before sending subsequent requests. +# +# PIPELINE boolean +# Set the value of -pipeline using http::config. The last PIPELINE command +# in the script applies to every request. Default 1. +# +# POSTFRESH boolean +# Set the value of -postfresh using http::config. The last POSTFRESH command +# in the script applies to every request. Default 0. +# +# REPOST boolean +# Set the value of -repost using http::config. The last REPOST command +# in the script applies to every request. Default 1 for httpTestScript. +# (Default value in http is 0). +# +# GET uriCode ?arg ...? +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and appended to the query +# string with a preceding "&". +# +# HEAD uriCode ?arg ...? +# Send a HTTP request using the HEAD method. +# Arguments: as for GET +# +# POST uriCode ?arg ...? +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + namespace export runHttpTestScript cleanupHttpTestScript +} + +# httpTestScript::START -- +# Initialise, and create a long-stop timeout. + +proc httpTestScript::START {} { + variable CountRequestedSoFar + variable RequestsWhenStopped + variable KeepAlive + variable Delay + variable TimeOutCode + variable TimeOutDone + variable StartDone + variable StopDone + variable CountFinishedSoFar + variable RequestList + variable RequestsMade + variable ExtraTime + variable ActualKeepAlive + + if {[info exists StartDone] && ($StartDone == 1)} { + set msg {START has been called twice without an intervening STOP} + return -code error $msg + } + + set StartDone 1 + set StopDone 0 + set TimeOutDone 0 + set CountFinishedSoFar 0 + set CountRequestedSoFar 0 + set RequestList {} + set RequestsMade {} + set ExtraTime 0 + set ActualKeepAlive 1 + + # Undefined until a STOP command: + unset -nocomplain RequestsWhenStopped + + # Default values: + set KeepAlive 1 + set Delay 500 + + # Default values for tests: + KEEPALIVE 1 + PIPELINE 1 + POSTFRESH 0 + REPOST 1 + + set TimeOutCode [after 30000 httpTestScript::TimeOutNow] +# set TimeOutCode [after 4000 httpTestScript::TimeOutNow] + return +} + +# httpTestScript::STOP -- +# Do not process any more commands. The commands will be executed but will +# silently do nothing. + +proc httpTestScript::STOP {} { + variable CountRequestedSoFar + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StartDone + variable StopDone + variable RequestsMade + + if {$StopDone} { + # Don't do anything on a second call. + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + set StopDone 1 + set StartDone 0 + set RequestsWhenStopped $CountRequestedSoFar + unset -nocomplain StartDone + + if {$CountFinishedSoFar == $RequestsWhenStopped} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + set ::httpTestScript::FOREVER 0 + } + return +} + +# httpTestScript::DELAY -- +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. + +proc httpTestScript::DELAY {t} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable Delay + + set Delay $t + return +} + +# httpTestScript::KEEPALIVE -- +# Set the value passed to http::geturl for the -keepalive option. Default 1. + +proc httpTestScript::KEEPALIVE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable KeepAlive + set KeepAlive $b + return +} + +# httpTestScript::WAIT -- +# Pause for a time in ms before processing any more commands. + +proc httpTestScript::WAIT {t} { + variable StartDone + variable StopDone + variable ExtraTime + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + if {(![string is integer -strict $t]) || $t < 0} { + return -code error {argument to WAIT must be a non-negative integer} + } + + incr ExtraTime $t + + return +} + +# httpTestScript::PIPELINE -- +# Pass a value to http::config -pipeline. + +proc httpTestScript::PIPELINE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -pipeline $b + ::http::Log http(-pipeline) is now [::http::config -pipeline] + return +} + +# httpTestScript::POSTFRESH -- +# Pass a value to http::config -postfresh. + +proc httpTestScript::POSTFRESH {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -postfresh $b + ::http::Log http(-postfresh) is now [::http::config -postfresh] + return +} + +# httpTestScript::REPOST -- +# Pass a value to http::config -repost. + +proc httpTestScript::REPOST {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -repost $b + ::http::Log http(-repost) is now [::http::config -repost] + return +} + +# httpTestScript::GET -- +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will each be preceded by "&" and appended to the query +# string. + +proc httpTestScript::GET {uriCode args} { + variable RequestList + lappend RequestList GET + RequestAfter $uriCode 0 {} {*}$args + return +} + +# httpTestScript::HEAD -- +# Send a HTTP request using the HEAD method. +# Arguments: as for GET + +proc httpTestScript::HEAD {uriCode args} { + variable RequestList + lappend RequestList HEAD + RequestAfter $uriCode 1 {} {*}$args + return +} + +# httpTestScript::POST -- +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. + +proc httpTestScript::POST {uriCode args} { + variable RequestList + lappend RequestList POST + RequestAfter $uriCode 0 {use} {*}$args + return +} + + +proc httpTestScript::RequestAfter {uriCode validate query args} { + variable CountRequestedSoFar + variable Delay + variable ExtraTime + variable StartDone + variable StopDone + variable KeepAlive + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + incr CountRequestedSoFar + set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}] + + # Could pass values of -pipeline, -postfresh, -repost if it were + # useful to change these mid-script. + after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args] + return +} + +proc httpTestScript::Requester {uriCode keepAlive validate query args} { + variable URL + + ::http::config -accept {*/*} + + set absUrl $URL($uriCode) + if {$query eq {}} { + if {$args ne {}} { + append absUrl & [join $args &] + } + set queryArgs {} + } elseif {$validate} { + return -code error {cannot have both -validate (HEAD) and -query (POST)} + } else { + set queryArgs [list -query [join $args &]] + } + + if {[catch { + ::http::geturl $absUrl \ + -validate $validate \ + -timeout 5000 \ + {*}$queryArgs \ + -keepalive $keepAlive \ + -command ::httpTestScript::WhenFinished + } token]} { + set msg $token + catch {puts stderr "Error: $msg"} + return + } else { + # Request will begin. + } + + return + +} + +proc httpTestScript::TimeOutNow {} { + variable TimeOutDone + + set TimeOutDone 1 + set ::httpTestScript::FOREVER 0 + return +} + +proc httpTestScript::WhenFinished {hToken} { + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StopDone + variable RequestList + variable RequestsMade + variable ActualKeepAlive + + upvar #0 $hToken state + + if {[catch { + if { [info exists state(transfer)] + && ($state(transfer) eq "chunked") + } { + set Trans chunked + } else { + set Trans unchunked + } + + if { [info exists ::httpTest::testOptions(-verbose)] + && ($::httpTest::testOptions(-verbose) > 0) + } { + puts "Token $hToken +Response $state(http) +Status $state(status) +Method $state(method) +Transfer $Trans +Size $state(currentsize) +URL $state(url) +" + } + + if {!$state(-keepalive)} { + set ActualKeepAlive 0 + } + + if {[info exists state(method)]} { + lappend RequestsMade $state(method) + } else { + lappend RequestsMade UNKNOWN + } + set tk [namespace tail $hToken] + + if { ($state(http) != {HTTP/1.1 200 OK}) + || ($state(status) != {ok}) + || (($state(currentsize) == 0) && ($state(method) ne "HEAD")) + } { + ::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken + } + } err]} { + ::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken + } + + incr CountFinishedSoFar + if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + if {$RequestsMade ne $RequestList && $ActualKeepAlive} { + ::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken + } + set ::httpTestScript::FOREVER 0 + } + + return +} + + +proc httpTestScript::runHttpTestScript {scr} { + variable TimeOutDone + variable RequestsWhenStopped + + after idle [list namespace eval ::httpTestScript $scr] + vwait ::httpTestScript::FOREVER + # N.B. does not automatically execute in this namespace, unlike some other events. + # Release when all requests have been served or have timed out. + + if {$TimeOutDone} { + return -code error {test script timed out} + } + + return $RequestsWhenStopped +} + + +proc httpTestScript::cleanupHttpTestScript {} { + variable TimeOutDone + variable RequestsWhenStopped + + if {![info exists RequestsWhenStopped]} { + return -code error {Cleanup Failed: RequestsWhenStopped is undefined} + } + + for {set i 1} {$i <= $RequestsWhenStopped} {incr i} { + http::cleanup ::http::$i + } + + return +} -- cgit v0.12 From a0e1b18138fb42f0dee9353735aa7938a1c19951 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 29 Mar 2018 18:20:56 +0000 Subject: Adapt tests/httpPipeline.test for test without installation. Comment out some Log calls from tests/httpTestScript.tcl --- tests/httpPipeline.test | 4 ++-- tests/httpTestScript.tcl | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 017661d..33462c05 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -809,10 +809,10 @@ for {set header 1} {$header <= 4} {incr header} { # Here's the test: test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \ -setup [string map [list TE $te] { - http::init - set http::http(uid) 0 # Restore default values for tests: http::config -pipeline 1 -postfresh 0 -repost 1 + http::init + set http::http(uid) 0 SetTestEof {TE} }] -body [list RunTest $header $footer $delay $te] -cleanup { # Restore default values for tests: diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index a826c81..048cb4f 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -253,7 +253,7 @@ proc httpTestScript::PIPELINE {b} { } ::http::config -pipeline $b - ::http::Log http(-pipeline) is now [::http::config -pipeline] + ##::http::Log http(-pipeline) is now [::http::config -pipeline] return } @@ -273,7 +273,7 @@ proc httpTestScript::POSTFRESH {b} { } ::http::config -postfresh $b - ::http::Log http(-postfresh) is now [::http::config -postfresh] + ##::http::Log http(-postfresh) is now [::http::config -postfresh] return } @@ -293,7 +293,7 @@ proc httpTestScript::REPOST {b} { } ::http::config -repost $b - ::http::Log http(-repost) is now [::http::config -repost] + ##::http::Log http(-repost) is now [::http::config -repost] return } -- cgit v0.12 From 3117af219fe5b0c4374266fd7f781223f3036eb9 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 30 Mar 2018 10:02:44 +0000 Subject: Bugfixes. Details in ticket 46b6edad51. --- library/http/http.tcl | 372 +++++++++++++++++++++++++++++++----------------- tests/httpPipeline.test | 3 +- 2 files changed, 241 insertions(+), 134 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index f4f83c6..a268e87 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -72,14 +72,20 @@ namespace eval http { variable socketClosing variable socketPlayCmd if {[info exists socketMapping]} { - # Close open sockets on re-init + # Close open sockets on re-init. Do not permit retries. foreach {url sock} [array get socketMapping] { - catch {close $sock} + unset -nocomplain socketClosing($url) + unset -nocomplain socketPlayCmd($url) + CloseSocket $sock } } - # Traces on "unset socketRdState(*)" will cancel any queued responses. - # Traces on "unset socketWrState(*)" will cancel any queued requests. + # CloseSocket should have unset the socket* arrays, one element at + # a time. Now unset anything that was overlooked. + # Traces on "unset socketRdState(*)" will call CancelReadPipeline and + # cancel any queued responses. + # Traces on "unset socketWrState(*)" will call CancelWritePipeline and + # cancel any queued requests. array unset socketMapping array unset socketRdState array unset socketWrState @@ -123,11 +129,12 @@ namespace eval http { } namespace export geturl config reset wait formatQuery register unregister - # Useful, but not exported: data size status code cleanup error meta ncode - # Also mapReply. + # Useful, but not exported: data size status code cleanup error meta ncode, + # mapReply, init. Comments suggest that "init" can be used for + # re-initialisation, although it is undocumented. # # Not exported, probably should be upper-case initial letter as part - # of the internals: init getTextLine make-transformation-chunked + # of the internals: getTextLine make-transformation-chunked } # http::Log -- @@ -264,6 +271,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } if {[info exists state(after)]} { after cancel $state(after) + unset state(after) } if {[info exists state(-command)] && (!$skipCB) && (![info exists state(done-command-cb)])} { @@ -291,6 +299,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # queued task if possible. Otherwise leave it idle and ready for its next # use. # +# If $socketClosing(*), then ($state(connection) eq "close") and therefore +# this command will not be called by Finish. +# # Arguments: # token Connection token. @@ -473,6 +484,8 @@ proc http::KeepSocket {token} { } else { CloseSocket $state(sock) $token + # There is no socketMapping($state(socketinfo)), so it does not matter + # that CloseQueuedQueries is not called. } return } @@ -551,7 +564,7 @@ proc http::CloseSocket {s {token {}}} { if {$token eq {}} { # Cases with a non-empty token are handled by Finish, so the tokens # are finished in connection order. - http::CloseQueuedQueries $connId $token + http::CloseQueuedQueries $connId } else { } } else { @@ -597,15 +610,46 @@ proc http::CloseQueuedQueries {connId {token {}}} { if { [info exists socketPlayCmd($connId)] && ($socketPlayCmd($connId) ne {ReplayIfClose Wready {} {}}) } { + # Before unsetting, there is some unfinished business. + # - If the server sent "Connection: close", we have stored the command + # for retrying any queued requests in socketPlayCmd, so copy that + # value for execution below. socketClosing(*) was also set. + # - Also clear the queues to prevent calls to Finish that would set the + # state for the requests that will be retried to "finished with error + # status". set unfinished $socketPlayCmd($connId) + set socketRdQueue($connId) {} + set socketWrQueue($connId) {} } else { set unfinished {} } - # The trace on "unset socketRdState(*)" cancels any pipelined - # responses. - # The trace on "unset socketWrState(*)" cancels any pipelined - # requests. + Unset $connId + + if {$unfinished ne {}} { + Log ^R$tk Any unfinished transactions (excluding $token) failed \ + - token $token + {*}$unfinished + } + return +} + +# http::Unset +# +# The trace on "unset socketRdState(*)" will call CancelReadPipeline +# and cancel any queued responses. +# The trace on "unset socketWrState(*)" will call CancelWritePipeline +# and cancel any queued requests. + +proc http::Unset {connId} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketClosing + variable socketPlayCmd + unset socketMapping($connId) unset socketRdState($connId) unset socketWrState($connId) @@ -614,11 +658,6 @@ proc http::CloseQueuedQueries {connId {token {}}} { unset -nocomplain socketClosing($connId) unset -nocomplain socketPlayCmd($connId) - if {$unfinished ne {}} { - Log ^R$tk Any unfinished transactions (excluding $token) failed \ - - token $token - {*}$unfinished - } return } @@ -977,45 +1016,39 @@ proc http::geturl {url args} { # - We leave this binding in place until just before the last # puts+flush in http::Connected (GET/HEAD) or http::Write (POST), # after which the HTTP response might be generated. - # - Therefore we must be prepared for full closure of the socket, - # and catch errors on any socket operation. - - if {[catch {fconfigure $socketMapping($state(socketinfo))}]} { - Log "WARNING: socket for $state(socketinfo) was closed\ - - token $token" - # The trace on "unset socketRdState(*)" cancels any pipelined - # responses. - # The trace on "`(*)" cancels any pipelined - # requests. - unset socketMapping($state(socketinfo)) - unset socketRdState($state(socketinfo)) - unset socketWrState($state(socketinfo)) - unset -nocomplain socketRdQueue($state(socketinfo)) - unset -nocomplain socketWrQueue($state(socketinfo)) - unset -nocomplain socketClosing($state(socketinfo)) - unset -nocomplain socketPlayCmd($state(socketinfo)) - - # Do not automatically close the eventual connection socket. - set state(connection) {} - } elseif { [info exists socketClosing($state(socketinfo))] + if { [info exists socketClosing($state(socketinfo))] && $socketClosing($state(socketinfo)) } { - # The server has sent a "Connection: close" header. + # socketClosing(*) is set because the server has sent a + # "Connection: close" header. # Do not use the persistent socket again. # Since we have only one persistent socket per server, and the # old socket is not yet dead, add the request to the write queue # of the dying socket, which will be replayed by ReplayIfClose. + # Also add it to socketWrQueue(*) which is used only if an error + # causes a call to Finish. set reusing 1 set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" - # Do not automatically close this connection socket. - set state(connection) {} set alreadyQueued 1 lassign $socketPlayCmd($state(socketinfo)) com0 com1 com2 com3 lappend com3 $token set socketPlayCmd($state(socketinfo)) [list $com0 $com1 $com2 $com3] + lappend socketWrQueue($state(socketinfo)) $token + } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} { + # FIXME Is it still possible for this code to be executed? If + # so, this could be another place to call TestForReplay, + # rather than discarding the queued transactions. + Log "WARNING: socket for $state(socketinfo) was closed\ + - token $token" + Log "WARNING - if testing, pay special attention to this\ + case (GH) which is seldom executed - token $token" + + # This will call CancelReadPipeline, CancelWritePipeline, and + # cancel any queued requests, responses. + Unset $state(socketinfo) } else { # Use the persistent socket. # The socket may not be ready to write: an earlier request might @@ -1026,9 +1059,9 @@ proc http::geturl {url args} { set sock $socketMapping($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo) - token $token" - # Do not automatically close this connection socket. - set state(connection) {} } + # Do not automatically close the connection socket. + set state(connection) {} } } @@ -1073,8 +1106,8 @@ proc http::geturl {url args} { # callback (if available) because we're going to throw an # exception from here instead. - set state(sock) $sock - Finish $token "" 1 + set state(sock) NONE + Finish $token $sock 1 cleanup $token return -code error $sock } else { @@ -1093,6 +1126,18 @@ proc http::geturl {url args} { } { # Freshly-opened socket that we would like to become persistent. set socketMapping($state(socketinfo)) $sock + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + 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. @@ -1108,16 +1153,10 @@ proc http::geturl {url args} { set socketWrState($state(socketinfo)) $token } - if {![info exists socketRdQueue($state(socketinfo))]} { - set socketRdQueue($state(socketinfo)) {} - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } - if {![info exists socketWrQueue($state(socketinfo))]} { - set socketWrQueue($state(socketinfo)) {} - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} } if {![info exists phost]} { @@ -1447,6 +1486,8 @@ proc http::Connected {token proto phost srvurl} { } err]} { # The socket probably was never connected, or the connection dropped # later. + Log "WARNING - if testing, pay special attention to this\ + case (GI) which is seldom executed - token $token" if {[info exists state(reusing)] && $state(reusing)} { # The socket was closed at the server end, and closed at # this end by http::CheckEof. @@ -1477,6 +1518,9 @@ proc http::Connected {token proto phost srvurl} { # # Command called when a request has been sent. It will arrange the # next request and/or response as appropriate. +# +# If this command is called when $socketClosing(*), the request $token +# that calls it must be pipelined and destined to fail. proc http::DoneRequest {token} { variable http @@ -1533,6 +1577,11 @@ proc http::DoneRequest {token} { } { # Do not read from the socket until it is ready. ##Log "HTTP response for token $token is queued for pipelined use" + # If $socketClosing(*), then the caller will be a pipelined write and + # execution will come here. + # This token has already been recorded as "in flight" for writing. + # When the socket is closed, the read queue will be cleared in + # CloseQueuedQueries and so the "lappend" here has no effect. lappend socketRdQueue($state(socketinfo)) $token } else { # In the pipelined case, connection for reading depends on the @@ -1575,12 +1624,18 @@ proc http::NextPipelinedWrite {token} { variable socketRdState variable socketWrState variable socketWrQueue - + variable socketClosing variable $token upvar 0 $token state set connId $state(socketinfo) - if { $state(-pipeline) + if { [info exists socketClosing($connId)] + && $socketClosing($connId) + } { + # socketClosing(*) is set because the server has sent a + # "Connection: close" header. + # Behave as if the queues are empty - so do nothing. + } elseif { $state(-pipeline) && [info exists socketWrState($connId)] && ($socketWrState($connId) eq "Wready") @@ -1663,11 +1718,13 @@ proc http::NextPipelinedWrite {token} { # # Cancel pipelined responses on a closing "Keep-Alive" socket. # -# - Called by a trace when the variable ::http::socketRdState($connId) is -# unset (the trace itself is automatically removed). +# - Called by a variable trace on "unset socketRdState($connId)". # - The variable relates to a Keep-Alive socket, which has been closed. # - Cancels all pipelined responses. The requests have been sent, # the responses have not yet been received. +# - This is a hard cancel that ends each transaction with error status, +# and closes the connection. Do not use it if you want to replay failed +# transactions. # - N.B. Always delete ::http::socketRdState($connId) before deleting # ::http::socketRdQueue($connId), or this command will do nothing. # @@ -1676,10 +1733,9 @@ proc http::NextPipelinedWrite {token} { proc http::CancelReadPipeline {name1 connId op} { variable socketRdQueue - ##Log CancelReadPipeline $name1 $connId $op if {[info exists socketRdQueue($connId)]} { - set msg {the connection was Closed} + set msg {the connection was closed by CancelReadPipeline} foreach token $socketRdQueue($connId) { set tk [namespace tail $token] Log ^X$tk end of response "($msg)" - token $token @@ -1695,12 +1751,13 @@ proc http::CancelReadPipeline {name1 connId op} { # # Cancel queued events on a closing "Keep-Alive" socket. # -# - Called by a trace when the variable ::http::socketWrState($connId) is -# unset (the trace itself is automatically removed). +# - Called by a variable trace on "unset socketWrState($connId)". # - The variable relates to a Keep-Alive socket, which has been closed. # - In pipelined or nonpipeline case: cancels all queued requests. The -# requests have not yet been sent, the responses are not due and have -# no data to cancel. +# requests have not yet been sent, the responses are not due. +# - This is a hard cancel that ends each transaction with error status, +# and closes the connection. Do not use it if you want to replay failed +# transactions. # - N.B. Always delete ::http::socketWrState($connId) before deleting # ::http::socketWrQueue($connId), or this command will do nothing. # @@ -1712,7 +1769,7 @@ proc http::CancelWritePipeline {name1 connId op} { ##Log CancelWritePipeline $name1 $connId $op if {[info exists socketWrQueue($connId)]} { - set msg {the connection was Closed} + set msg {the connection was closed by CancelWritePipeline} foreach token $socketWrQueue($connId) { set tk [namespace tail $token] Log ^X$tk end of response "($msg)" - token $token @@ -1844,30 +1901,20 @@ proc http::ReplayIfDead {tokenArg doing} { # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket. - # CloseSocket cancels file events, closes the socket, and unsets the - # socketMapping. - # Finish calls CloseSocket, if called as below. - # Don't want Eot. # Do not change state(status). - # Want to not unset socketWrState(*). + # No need to after cancel stateArg(after) - either this is done in + # ReplayCore/ReInit, or Finish is called. - if {[info exists stateArg(after)]} { - after cancel $stateArg(after) - } catch {close $stateArg(sock)} - # The relevant element of socketMapping, socketRdState, socketWrState, - # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set to - # new values in ReplayCore. - # The trace on "unset socketRdState(*)" cancels any pipelined responses. - # It also clears socketRdQueue(*). - # Transactions, if any, that are awaiting responses cannot be completed. - # They are listed for re-sending in newQueue. - # There is no need to unset socketWrState - the write queue transactions - # have not yet been sent, nor the state(-timeout) events. - # All tokens are preserved for re-use by ReplayCore. - - unset socketRdState($stateArg(socketinfo)) + # 2a. Tidy the tokens in the queues - this is done in ReplayCore/ReInit. + # - Transactions, if any, that are awaiting responses cannot be completed. + # They are listed for re-sending in newQueue. + # - All tokens are preserved for re-use by ReplayCore, and their variables + # will be re-initialised by calls to ReInit. + # - The relevant element of socketMapping, socketRdState, socketWrState, + # socketRdQueue, socketWrQueue, socketClosing, socketPlayCmd will be set + # to new values in ReplayCore. ReplayCore $newQueue return @@ -1913,6 +1960,72 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} { return } +# http::ReInit -- +# +# Command to restore a token's state to a condition that +# makes it ready to replay a request. +# +# Command http::geturl stores extra state in state(tmp*) so +# we don't need to do the argument processing again. +# +# The caller must: +# - Set state(reusing) and state(sock) to their new values after calling +# this command. +# - Unset state(tmpState), state(tmpOpenCmd) if future calls to ReplayCore +# or ReInit are inappropriate for this token. Typically only one retry +# is allowed. +# The caller may also unset state(tmpConnArgs) if this value (and the +# token) will be used immediately. The value is needed by tokens that +# will be stored in a queue. +# +# Arguments: +# token Connection token. +# +# Return Value: (boolean) true iff the re-initialisation was successful. + +proc http::ReInit {token} { + variable $token + upvar 0 $token state + + if {!( + [info exists state(tmpState)] + && [info exists state(tmpOpenCmd)] + && [info exists state(tmpConnArgs)] + ) + } { + Log FAILED in http::ReInit via ReplayCore - NO tmp vars for $token + return 0 + } + + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + + # Don't alter state(status) - this would trigger http::wait if it is in use. + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + foreach name [array names state] { + if {$name ne "status"} { + unset state($name) + } + } + + # Don't alter state(status). + # Restore state(tmp*) - the caller may decide to unset them. + # Restore state(tmpConnArgs) which is needed for connection. + # state(tmpState), state(tmpOpenCmd) are needed only for retries. + + dict unset tmpState status + array set state $tmpState + set state(tmpState) $tmpState + set state(tmpOpenCmd) $tmpOpenCmd + set state(tmpConnArgs) $tmpConnArgs + + return 1 +} + # http::ReplayCore -- # # Command to replay a list of requests, using existing connection tokens. @@ -1951,30 +2064,19 @@ proc http::ReplayCore {newQueue} { variable $token upvar 0 $token state - if {!( - [info exists state(tmpState)] - && [info exists state(tmpOpenCmd)] - && [info exists state(tmpConnArgs)] - ) - } { + if {![ReInit $token]} { Log FAILED in http::ReplayCore - NO tmp vars - Finish $token error 1 + Finish $token {cannot send this request again} return } - # Don't alter state(status) - this would trigger http::wait if it is in use. set tmpState $state(tmpState) set tmpOpenCmd $state(tmpOpenCmd) set tmpConnArgs $state(tmpConnArgs) - foreach name [array names state] { - if {$name ne "status"} { - unset state($name) - } - } + unset state(tmpState) + unset state(tmpOpenCmd) + unset state(tmpConnArgs) - # Don't alter state(status). - dict unset tmpState status - array set state $tmpState set state(reusing) 0 if {$state(-timeout) > 0} { @@ -1985,15 +2087,28 @@ proc http::ReplayCore {newQueue} { # 4. Open a socket. if {[catch {eval $tmpOpenCmd} sock]} { # Something went wrong while trying to establish the connection. - Log FAILED - $tmpOpenCmd - set state(sock) $sock - Finish $token error 1 + Log FAILED - $sock + set state(sock) NONE + Finish $token $sock return } # 5. Configure the persistent socket data. if {$state(-keepalive)} { set socketMapping($state(socketinfo)) $sock + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + if {$state(-pipeline)} { #Log new, init for pipelined, GRANT write acc to $token ReplayCore set socketRdState($state(socketinfo)) $token @@ -2004,26 +2119,22 @@ proc http::ReplayCore {newQueue} { set socketWrState($state(socketinfo)) $token } - if {![info exists socketRdQueue($state(socketinfo))]} { - set socketRdQueue($state(socketinfo)) {} - set varName ::http::socketRdState($state(socketinfo)) - trace add variable $varName unset ::http::CancelReadPipeline - } set socketRdQueue($state(socketinfo)) {} - - if {![info exists socketWrQueue($state(socketinfo))]} { - set socketWrQueue($state(socketinfo)) {} - set varName ::http::socketWrState($state(socketinfo)) - trace add variable $varName unset ::http::CancelWritePipeline - } set socketWrQueue($state(socketinfo)) $newQueue set socketClosing($state(socketinfo)) 0 - set socketPlayCmd($state(socketinfo)) {} + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} } # 6. Configure sockets in the queue. foreach tok $newQueue { - set ${tok}(sock) $sock + if {[ReInit $tok]} { + set ${tok}(reusing) 1 + set ${tok}(sock) $sock + } else { + set ${tok}(reusing) 1 + set ${tok}(sock) NONE + Finish $token {cannot send this request again} + } } # 7. Configure the socket for newToken to send a request. @@ -2131,6 +2242,8 @@ proc http::Connect {token proto phost srvurl} { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" } { + Log "WARNING - if testing, pay special attention to this\ + case (GJ) which is seldom executed - token $token" if {[info exists state(reusing)] && $state(reusing)} { # The socket was closed at the server end, and closed at # this end by http::CheckEof. @@ -2309,6 +2422,8 @@ proc http::Event {sock token} { } if {[catch {gets $sock state(http)} nsl]} { + Log "WARNING - if testing, pay special attention to this\ + case (GK) which is seldom executed - token $token" if {[info exists state(reusing)] && $state(reusing)} { # The socket was closed at the server end, and closed at # this end by http::CheckEof. @@ -2418,27 +2533,18 @@ proc http::Event {sock token} { $socketRdQueue($state(socketinfo)) \ $socketWrQueue($state(socketinfo))] - # See discussion below. + # - All tokens are preserved for re-use by ReplayCore. + # - Queues are preserved in case of Finish with error, but + # are not used for anything else because socketClosing(*) + # is set below. + # - Cancel the state(after) timeout events. foreach tokenElement $socketRdQueue($state(socketinfo)) { if {[info exists ${tokenElement}(after)]} { after cancel [set ${tokenElement}(after)] + unset ${tokenElement}(after) } } - # - Clear the queues. By doing this here, the code for - # connecting the next token to the socket needs no - # modification. - # - Do not unset socketRdState and socketWrState and trigger - # their traces, because this will close the socket, which - # is still needed for the current read. - # - The only other thing that the traces would have done is - # cancel the state(after) timeout events. This is now - # done above. - # - All tokens are preserved for re-use by ReplayCore. - - set socketRdQueue($state(socketinfo)) {} - set socketWrQueue($state(socketinfo)) {} - } else { set socketPlayCmd($state(socketinfo)) \ {ReplayIfClose Wready {} {}} diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 33462c05..cab36b2 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -807,7 +807,8 @@ for {set header 1} {$header <= 4} {incr header} { # Here's the test: - test http11-${header}.${footer}${label}-${tag} $name -constraints $cons \ + test httpPipeline-${header}.${footer}${label}-${tag} $name \ + -constraints $cons \ -setup [string map [list TE $te] { # Restore default values for tests: http::config -pipeline 1 -postfresh 0 -repost 1 -- cgit v0.12 From 441e4f6796e1e3cecba7872500d68d0ebbf3a943 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 30 Mar 2018 10:13:57 +0000 Subject: For thorough testing, set test file to verbose, and uncomment Log calls in http.tcl. --- library/http/http.tcl | 108 ++++++++++++++++++++++++------------------------ tests/httpPipeline.test | 2 +- 2 files changed, 55 insertions(+), 55 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index a268e87..ac51370 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -355,7 +355,7 @@ proc http::KeepSocket {token} { upvar 0 $token3 state3 set tk2 [namespace tail $token3] - #Log pipelined, GRANT read access to $token3 in KeepSocket + Log #Log pipelined, GRANT read access to $token3 in KeepSocket set socketRdState($connId) $token3 lassign [fconfigure $state3(sock) -translation] trRead trWrite fconfigure $state3(sock) -translation [list auto $trWrite] \ @@ -363,7 +363,7 @@ proc http::KeepSocket {token} { Log ^D$tk2 begin receiving response - token $token3 fileevent $state3(sock) readable \ [list http::Event $state3(sock) $token3] - #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a) + Log #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a) # Other pipelined cases. # - The test above ensures that, for the pipelined cases in the two @@ -400,13 +400,13 @@ proc http::KeepSocket {token} { # give that request read and write access. variable $token3 set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { $state(-pipeline) @@ -445,13 +445,13 @@ proc http::KeepSocket {token} { # case with a queued request. variable $token3 set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { (!$state(-pipeline)) @@ -467,13 +467,13 @@ proc http::KeepSocket {token} { set token3 [lindex $socketWrQueue($connId) 0] variable $token3 set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (d) + Log #Log ---- $state(sock) << conn to $token3 for HTTP request (d) } elseif {(!$state(-pipeline))} { set socketWrState($connId) Wready @@ -713,7 +713,7 @@ proc http::geturl {url args} { set http(uid) 0 } set token [namespace current]::[incr http(uid)] - ##Log Starting http::geturl - token $token + Log ##Log Starting http::geturl - token $token variable $token upvar 0 $token state set tk [namespace tail $token] @@ -1139,7 +1139,7 @@ proc http::geturl {url args} { } if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write access to $token in geturl + Log #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 @@ -1148,7 +1148,7 @@ proc http::geturl {url args} { # 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 + Log #Log new, init for nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } @@ -1193,13 +1193,13 @@ proc http::geturl {url args} { # subsequent calls on this socket will come here because the socket # will close after the current read, and its # socketClosing($connId) is 1. - ##Log "HTTP request for token $token is queued" + Log ##Log "HTTP request for token $token is queued" } elseif { $reusing && $state(-pipeline) && ($socketWrState($state(socketinfo)) ne "Wready") } { - ##Log "HTTP request for token $token is queued for pipelined use" + Log ##Log "HTTP request for token $token is queued for pipelined use" lappend socketWrQueue($state(socketinfo)) $token } elseif { $reusing @@ -1207,7 +1207,7 @@ proc http::geturl {url args} { && ($socketWrState($state(socketinfo)) ne "Wready") } { # A write is queued or in progress. Lappend to the write queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" + Log ##Log "HTTP request for token $token is queued for nonpipeline use" lappend socketWrQueue($state(socketinfo)) $token } elseif { $reusing @@ -1218,20 +1218,20 @@ proc http::geturl {url args} { # A read is queued or in progress, but not a write. Cannot start the # nonpipeline transaction, but must set socketWrState to prevent a # pipelined request jumping the queue. - ##Log "HTTP request for token $token is queued for nonpipeline use" - #Log re-use nonpipeline, GRANT delayed write access to $token in geturl + Log ##Log "HTTP request for token $token is queued for nonpipeline use" + Log #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { if {$reusing && $state(-pipeline)} { - #Log re-use pipelined, GRANT write access to $token in geturl + Log #Log re-use pipelined, GRANT write access to $token in geturl set socketWrState($state(socketinfo)) $token } elseif {$reusing} { # Cf tests above - both are ready. - #Log re-use nonpipeline, GRANT r/w access to $token in geturl + Log #Log re-use nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token @@ -1241,7 +1241,7 @@ proc http::geturl {url args} { # All (!$reusing) cases come here, and also some $reusing cases if the # connection is ready. - #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + Log #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) # Connect does its own fconfigure. fileevent $sock writable \ [list http::Connect $token $proto $phost $srvurl] @@ -1268,7 +1268,7 @@ proc http::geturl {url args} { return -code error $err } } - ##Log Leaving http::geturl - token $token + Log ##Log Leaving http::geturl - token $token return $token } @@ -1566,7 +1566,7 @@ proc http::DoneRequest {token} { && [info exists socketRdState($state(socketinfo))] && ($socketRdState($state(socketinfo)) eq "Rready") } { - #Log pipelined, GRANT read access to $token in Connected + Log #Log pipelined, GRANT read access to $token in Connected set socketRdState($state(socketinfo)) $token } @@ -1576,7 +1576,7 @@ proc http::DoneRequest {token} { && ($socketRdState($state(socketinfo)) ne $token) } { # Do not read from the socket until it is ready. - ##Log "HTTP response for token $token is queued for pipelined use" + Log ##Log "HTTP response for token $token is queued for pipelined use" # If $socketClosing(*), then the caller will be a pipelined write and # execution will come here. # This token has already been recorded as "in flight" for writing. @@ -1587,7 +1587,7 @@ proc http::DoneRequest {token} { # In the pipelined case, connection for reading depends on the # value of socketRdState. # In the nonpipeline case, connection for reading always occurs. - #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b) + Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b) lassign [fconfigure $sock -translation] trRead trWrite fconfigure $sock -translation [list auto $trWrite] \ -buffersize $state(-blocksize) @@ -1647,13 +1647,13 @@ proc http::NextPipelinedWrite {token} { ) } { # - The usual case for a pipelined connection, ready for a new request. - #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite + Log #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite set conn [set ${token2}(tmpConnArgs)] set socketWrState($connId) $token2 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] - #Log ---- $connId << conn to $token2 for HTTP request (b) + Log #Log ---- $connId << conn to $token2 for HTTP request (b) # In the tests below, the next request will be nonpipeline. } elseif { $state(-pipeline) @@ -1676,13 +1676,13 @@ proc http::NextPipelinedWrite {token} { variable $token3 upvar 0 $token3 state3 set conn [set ${token3}(tmpConnArgs)] - #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite + Log #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { $state(-pipeline) && [info exists socketWrState($connId)] @@ -1704,7 +1704,7 @@ proc http::NextPipelinedWrite {token} { # of the connection to $token2 will be done elsewhere - by command # http::KeepSocket when $socketRdState($connId) is set to "Rready". - #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. + Log #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. set socketWrState($connId) peNding } else { @@ -1733,7 +1733,7 @@ proc http::NextPipelinedWrite {token} { proc http::CancelReadPipeline {name1 connId op} { variable socketRdQueue - ##Log CancelReadPipeline $name1 $connId $op + Log ##Log CancelReadPipeline $name1 $connId $op if {[info exists socketRdQueue($connId)]} { set msg {the connection was closed by CancelReadPipeline} foreach token $socketRdQueue($connId) { @@ -1767,7 +1767,7 @@ proc http::CancelReadPipeline {name1 connId op} { proc http::CancelWritePipeline {name1 connId op} { variable socketWrQueue - ##Log CancelWritePipeline $name1 $connId $op + Log ##Log CancelWritePipeline $name1 $connId $op if {[info exists socketWrQueue($connId)]} { set msg {the connection was closed by CancelWritePipeline} foreach token $socketWrQueue($connId) { @@ -2053,7 +2053,7 @@ proc http::ReplayCore {newQueue} { return } - ##Log running ReplayCore for {*}$newQueue + Log ##Log running ReplayCore for {*}$newQueue set newToken [lindex $newQueue 0] set newQueue [lrange $newQueue 1 end] @@ -2110,11 +2110,11 @@ proc http::ReplayCore {newQueue} { } if {$state(-pipeline)} { - #Log new, init for pipelined, GRANT write acc to $token ReplayCore + Log #Log new, init for pipelined, GRANT write acc to $token ReplayCore set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } else { - #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore + Log #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } @@ -2147,7 +2147,7 @@ proc http::ReplayCore {newQueue} { # Connect does its own fconfigure. fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] - #Log ---- $sock << conn to $token for HTTP request (e) + Log #Log ---- $sock << conn to $token for HTTP request (e) return } @@ -2396,7 +2396,7 @@ proc http::Event {sock token} { upvar 0 $token state set tk [namespace tail $token] - ##Log Event call - token $token + Log ##Log Event call - token $token if {![info exists state]} { Log "Event $sock with invalid token '$token' - remote close?" @@ -2411,7 +2411,7 @@ proc http::Event {sock token} { return } if {$state(state) eq "connecting"} { - ##Log - connecting - token $token + Log ##Log - connecting - token $token if { $state(reusing) && $state(-pipeline) && ($state(-timeout) > 0) @@ -2443,7 +2443,7 @@ proc http::Event {sock token} { return } } elseif {$nsl >= 0} { - ##Log - connecting 1 - token $token + Log ##Log - connecting 1 - token $token set state(state) "header" } elseif { [eof $sock] && [info exists state(reusing)] @@ -2463,18 +2463,18 @@ proc http::Event {sock token} { # If any other requests are in flight or pipelined/queued, they will # be discarded. } else { - ##Log - connecting 2 - token $token + Log ##Log - connecting 2 - token $token # nsl is -1 so either fblocked (OK) or (eof and not reusing). # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { - ##Log header failed - token $token + Log ##Log header failed - token $token Log ^X$tk end of response (error) - token $token Finish $token $nhl return } elseif {$nhl == 0} { - ##Log header done - token $token + Log ##Log header done - token $token Log ^E$tk end of response headers - token $token # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 @@ -2513,7 +2513,7 @@ proc http::Event {sock token} { } { # The server warns that it will close the socket after this # response. - ##Log WARNING - socket will close after response for $token + Log ##Log WARNING - socket will close after response for $token # Prepare data for a call to ReplayIfClose. if { ($socketRdQueue($state(socketinfo)) ne {}) || ($socketWrQueue($state(socketinfo)) ne {}) @@ -2525,7 +2525,7 @@ proc http::Event {sock token} { set InFlightW Wready } else { set msg "token ${InFlightW} is InFlightW" - ##Log $msg - token $token + Log ##Log $msg - token $token } set socketPlayCmd($state(socketinfo)) \ @@ -2617,7 +2617,7 @@ proc http::Event {sock token} { } } elseif {$nhl > 0} { # Process header lines. - ##Log header - token $token - $line + Log ##Log header - token $token - $line if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { switch -- [string tolower $key] { content-type { @@ -2653,11 +2653,11 @@ proc http::Event {sock token} { } } else { # Now reading body - ##Log body - token $token + Log ##Log body - token $token if {[catch { if {[info exists state(-handler)]} { set n [eval $state(-handler) [list $sock $token]] - ##Log handler $n - token $token + Log ##Log handler $n - token $token # N.B. the protocol has been set to 1.0 because the -handler # logic is not expected to handle chunked encoding. # FIXME allow -handler with 1.1 on dechunked stacked channel. @@ -2710,14 +2710,14 @@ proc http::Event {sock token} { } elseif { [info exists state(transfer)] && ($state(transfer) eq "chunked") } { - ##Log chunked - token $token + Log ##Log chunked - token $token set size 0 set hexLenChunk [getTextLine $sock] #set ntl [string length $hexLenChunk] if {[string trim $hexLenChunk] ne ""} { scan $hexLenChunk %x size if {$size != 0} { - ##Log chunk-measure $size - token $token + Log ##Log chunk-measure $size - token $token set bl [fconfigure $sock -blocking] fconfigure $sock -blocking 1 set chunk [read $sock $size] @@ -2726,7 +2726,7 @@ proc http::Event {sock token} { if {$n >= 0} { append state(body) $chunk incr state(log_size) [string length $chunk] - ##Log chunk $n cumul $state(log_size) - token $token + Log ##Log chunk $n cumul $state(log_size) - token $token } if {$size != [string length $chunk]} { Log "WARNING: mis-sized chunk:\ @@ -2748,14 +2748,14 @@ proc http::Event {sock token} { } } else { # Line expected to hold chunk length is empty. - ##Log bad-chunk-measure - token $token + Log ##Log bad-chunk-measure - token $token set n 0 set state(connection) close Log ^X$tk end of response (chunk error) - token $token Eot $token {error in chunked encoding - fetch terminated} } } else { - ##Log unchunked - token $token + Log ##Log unchunked - token $token if {$state(totalsize) == 0} { # We know the transfer is complete only when the server # closes the connection. @@ -2775,12 +2775,12 @@ proc http::Event {sock token} { } set c $state(currentsize) set t $state(totalsize) - ##Log non-chunk currentsize $c of totalsize $t - token $token + Log ##Log non-chunk currentsize $c of totalsize $t - token $token set block [read $sock $reqSize] set n [string length $block] if {$n >= 0} { append state(body) $block - ##Log non-chunk [string length $state(body)] - token $token + Log ##Log non-chunk [string length $state(body)] - token $token } } # This calculation uses n from the -handler, chunked, or unchunked @@ -2790,7 +2790,7 @@ proc http::Event {sock token} { incr state(currentsize) $n set c $state(currentsize) set t $state(totalsize) - ##Log chunk $n currentsize $c totalsize $t - token $token + Log ##Log chunk $n currentsize $c totalsize $t - token $token } # If Content-Length - check for end of data. if { @@ -2817,7 +2817,7 @@ proc http::Event {sock token} { # catch as an Eot above may have closed the socket already # $state(state) may be connecting, header, body, or complete if {![catch {eof $sock} eof] && $eof} { - ##Log eof - token $token + Log ##Log eof - token $token if {[info exists $token]} { set state(connection) close if {$state(state) eq "complete"} { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index cab36b2..08eb076 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -641,7 +641,7 @@ proc RunTest {header footer delay te} { # If still obscure, uncomment #Log and ##Log lines in the http package. # ------------------------------------------------------------------------------ -set ::httpTest::testOptions(-verbose) 0 +set ::httpTest::testOptions(-verbose) 2 # ------------------------------------------------------------------------------ -- cgit v0.12 From 466fd1d9304f60660938226a59e6ed8156a0d02e Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 31 Mar 2018 15:27:52 +0000 Subject: Chasing timeout bug: reduce client timeout to 4s in tests; more sanity checking in non-keep-alive tests; tidying; more logging in http.tcl. --- library/http/http.tcl | 29 ++++++++++++++++-- tests/httpPipeline.test | 26 ++++++++++------- tests/httpTest.tcl | 76 +++++++++++++++++++++++++++++++++++++++++++++++- tests/httpTestScript.tcl | 2 +- 4 files changed, 119 insertions(+), 14 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index ac51370..49898db 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1086,7 +1086,7 @@ proc http::geturl {url args} { # - DoneRequest - if reusing and pipelined, send the next pipelined write # - Event - if reusing and pipelined, start the state(-timeout) # timeout (when reading). - # - Event - if not reusing and pipelined, send the next pipelined + # - Event - if (not reusing) and pipelined, send the next pipelined # write # See comments above re the start of this timeout in other cases. @@ -1100,6 +1100,9 @@ proc http::geturl {url args} { if {[info exists state(-myaddr)]} { lappend sockopts -myaddr $state(-myaddr) } + set pre [clock milliseconds] + Log ##Log pre socket opened, - token $token + Log ##Log [concat $defcmd $sockopts $targetAddr] - token $token if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { # Something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command @@ -1112,10 +1115,19 @@ proc http::geturl {url args} { return -code error $sock } else { # Initialisation of a new socket. + Log ##Log post socket opened, - token $token + Log ##Log socket opened, now fconfigure - token $token + set delay [expr {[clock milliseconds] - $pre}] + if {$delay > 3000} { + Log ##Log socket delay $delay - token $token + } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) + Log ##Log socket opened, DONE fconfigure - token $token } } + # Command [socket] is called with -async, but occasionally takes seconds to return. + # It returns after 5s, and the request times out when this command returns. set state(sock) $sock Log "Using $sock for $state(socketinfo) - token $token" \ @@ -2084,6 +2096,9 @@ proc http::ReplayCore {newQueue} { set state(after) [after $state(-timeout) $resetCmd] } + set pre [clock milliseconds] + Log ##Log pre socket opened, - token $token + Log ##Log $tmpOpenCmd - token $token # 4. Open a socket. if {[catch {eval $tmpOpenCmd} sock]} { # Something went wrong while trying to establish the connection. @@ -2092,6 +2107,13 @@ proc http::ReplayCore {newQueue} { Finish $token $sock return } + Log ##Log post socket opened, - token $token + set delay [expr {[clock milliseconds] - $pre}] + if {$delay > 3000} { + Log ##Log socket delay $delay - token $token + } + # Command [socket] is called with -async, but occasionally takes seconds to return. + # It returns after 5s, and the request times out when this command returns. # 5. Configure the persistent socket data. if {$state(-keepalive)} { @@ -2125,6 +2147,7 @@ proc http::ReplayCore {newQueue} { set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} } + Log ##Log pre newQueue ReInit, - token $token # 6. Configure sockets in the queue. foreach tok $newQueue { if {[ReInit $tok]} { @@ -2143,7 +2166,9 @@ proc http::ReplayCore {newQueue} { [expr {$state(-keepalive)?"keepalive":""}] # Initialisation of a new socket. + Log ##Log socket opened, now fconfigure - token $token fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) + Log ##Log socket opened, DONE fconfigure - token $token # Connect does its own fconfigure. fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] @@ -2790,7 +2815,7 @@ proc http::Event {sock token} { incr state(currentsize) $n set c $state(currentsize) set t $state(totalsize) - Log ##Log chunk $n currentsize $c totalsize $t - token $token + Log ##Log another $n currentsize $c totalsize $t - token $token } # If Content-Length - check for end of data. if { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 08eb076..4823d19 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -566,10 +566,14 @@ proc ReturnTestResult {ca cb delay te} { namespace import httpTestScript::runHttpTestScript namespace import httpTestScript::cleanupHttpTestScript +namespace import httpTest::cleanupHttpTest +namespace import httpTest::logAnalyse +namespace import httpTest::setHttpTestOptions proc RunTest {header footer delay te} { set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]] set skipOverlaps 0 + set notPiped {} set notIncluded {} # -------------------------------------------------------------------------- @@ -578,23 +582,26 @@ proc RunTest {header footer delay te} { if {$header < 3} { set skipOverlaps 1 for {set i 1} {$i <= $num} {incr i} { - lappend notIncluded $i + lappend notPiped $i } } elseif {$header > 2 && $footer == 18 && $te == 1} { set skipOverlaps 1 if {$delay == 0} { # Transaction 1 is conventional. # Check that transactions 2,3,4 are cancelled. - set notIncluded {1} + set notPiped {1} + set notIncluded $notPiped } else { # Transaction 1 is conventional. # Check that transaction 2 is cancelled. # The timing of transactions 3 and 4 is uncertain. - set notIncluded {1 3 4} + set notPiped {1 3 4} + set notIncluded $notPiped } } elseif {$footer in {20 22 23 24 25}} { # Transaction 2 uses its own socket. - set notIncluded 2 + set notPiped 2 + set notIncluded $notPiped } else { } # -------------------------------------------------------------------------- @@ -602,7 +609,7 @@ proc RunTest {header footer delay te} { # -------------------------------------------------------------------------- - set Results [httpTest::LogAnalyse $num $skipOverlaps $notIncluded $notIncluded] + set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped] lassign $Results msg cleanE cleanF dirtyE dirtyF if {$msg eq {}} { set msg "Passed all sanity checks." @@ -641,8 +648,7 @@ proc RunTest {header footer delay te} { # If still obscure, uncomment #Log and ##Log lines in the http package. # ------------------------------------------------------------------------------ -set ::httpTest::testOptions(-verbose) 2 - +setHttpTestOptions -verbose 2 # ------------------------------------------------------------------------------ # (4) Define the base URLs used for testing. Each must have a query string. @@ -724,10 +730,10 @@ proc SetTestEof {test} { for {set header 1} {$header <= 4} {incr header} { if {$header == 4} { - set ::httpTest::testOptions(-dotted) 1 + setHttpTestOptions -dotted 1 set match glob } else { - set ::httpTest::testOptions(-dotted) 0 + setHttpTestOptions -dotted 0 set match exact } @@ -820,7 +826,7 @@ for {set header 1} {$header <= 4} {incr header} { http::config -pipeline 1 -postfresh 0 -repost 1 cleanupHttpTestScript SetTestEof 0 - set ::httpTest::testResults {} + cleanupHttpTest after 2000 # Wait for persistent sockets on the server to time out. } -result [ReturnTestResult $header $footer $delay $te] -match $match diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index ad08048..38ba43f 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -25,6 +25,7 @@ package require http namespace eval ::http { variable TestStartTimeInMs [clock milliseconds] + catch {puts stderr "Start time (zero ms) is $TestStartTimeInMs"} } namespace eval ::httpTest { @@ -297,6 +298,32 @@ proc httpTest::TestSequence {someResults n msg badTrans} { return $msg } +# +# Arguments: +# someResults - list of elements, each a list of a letter and a number +# n - (positive integer) the number of HTTP requests +# msg - accumulated warning messages +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# for 1/2 includes all transactions +# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled. +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: nothing will be appended to argument $msg if there +# is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} { variable testOptions @@ -362,6 +389,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip set last [lsearch -exact $beforeTry [list F $i]] if {$first == -1} { set res "Transaction $i was not started in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n Puts $res if {$i ni $badTrans} { @@ -370,12 +398,16 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip } } elseif {$last == -1} { set res "Transaction $i was started but unfinished in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n Puts $res lappend badTrans $i lappend dummyTry [list A $i] } else { set res "Transaction $i was started and finished in connection number $tryCount" + # So include it in the call below of MostAnalysis. + # So lappend it to notIncluded and don't include it in the recursive call of + # ProcessRetries which handles the later connections. # append msg $res \n Puts $res lappend notIncluded $i @@ -398,7 +430,31 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip return [list $msg $cleanE $cleanF $dirtyE $dirtyF] } -proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} { +# httpTest::logAnalyse -- +# +# The main command called to analyse logs for a single test. +# +# Arguments: +# n - (positive integer) the number of HTTP requests +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# notIncluded - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# notPiped - subset of notIncluded. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: {} if there is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + +proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} { variable testResults variable testOptions @@ -429,3 +485,21 @@ proc httpTest::LogAnalyse {n skipOverlaps notIncluded notPiped} { ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped # N.B. Implicit Return. } + +proc httpTest::cleanupHttpTest {} { + variable testResults + set testResults {} + return +} + +proc httpTest::setHttpTestOptions {key args} { + variable testOptions + if {$key ni {-dotted -verbose}} { + return -code error {valid options are -dotted, -verbose} + } + set testOptions($key) {*}$args +} + +namespace eval httpTest { + namespace export cleanupHttpTest logAnalyse setHttpTestOptions +} diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index 048cb4f..68b3474 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -383,7 +383,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} { if {[catch { ::http::geturl $absUrl \ -validate $validate \ - -timeout 5000 \ + -timeout 4000 \ {*}$queryArgs \ -keepalive $keepAlive \ -command ::httpTestScript::WhenFinished -- cgit v0.12 From 13571723674678c9c380ee2e6f2f5bc44777f58f Mon Sep 17 00:00:00 2001 From: kjnash Date: Sun, 1 Apr 2018 01:09:57 +0000 Subject: Increase test timeout to 10s. Remove commenting from Log calls that report long delay for [socket]. --- library/http/http.tcl | 18 ++++++++++++------ tests/httpTestScript.tcl | 2 +- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 49898db..83a4665 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1119,15 +1119,18 @@ proc http::geturl {url args} { Log ##Log socket opened, now fconfigure - token $token set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { - Log ##Log socket delay $delay - token $token + Log socket delay $delay - token $token } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) Log ##Log socket opened, DONE fconfigure - token $token } } - # Command [socket] is called with -async, but occasionally takes seconds to return. - # It returns after 5s, and the request times out when this command returns. + # Command [socket] is called with -async, but takes 5s to 5.1s to return, + # with probability of order 1 in 10,000. This may be a bizarre scheduling + # issue with my (KJN's) system (Fedora Linux). + # This does not cause a problem (unless the request times out when this + # command returns). set state(sock) $sock Log "Using $sock for $state(socketinfo) - token $token" \ @@ -2110,10 +2113,13 @@ proc http::ReplayCore {newQueue} { Log ##Log post socket opened, - token $token set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { - Log ##Log socket delay $delay - token $token + Log socket delay $delay - token $token } - # Command [socket] is called with -async, but occasionally takes seconds to return. - # It returns after 5s, and the request times out when this command returns. + # Command [socket] is called with -async, but takes 5s to 5.1s to return, + # with probability of order 1 in 10,000. This may be a bizarre scheduling + # issue with my (KJN's) system (Fedora Linux). + # This does not cause a problem (unless the request times out when this + # command returns). # 5. Configure the persistent socket data. if {$state(-keepalive)} { diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index 68b3474..4046c7a 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -383,7 +383,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} { if {[catch { ::http::geturl $absUrl \ -validate $validate \ - -timeout 4000 \ + -timeout 10000 \ {*}$queryArgs \ -keepalive $keepAlive \ -command ::httpTestScript::WhenFinished -- cgit v0.12 From 6a58a0cab24668a9c1feda011147c87f3ba34801 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 4 Apr 2018 12:00:03 +0000 Subject: Use coroutines to remove blocking on HTTP connections --- library/http/http.tcl | 874 +++++++++++++++++++++++++++----------------------- 1 file changed, 466 insertions(+), 408 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 83a4665..77a2a43 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -255,6 +255,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(error) [list $errormsg $errorInfo $errorCode] set state(status) "error" } + if {[info commands ${token}EventCoroutine] ne {}} { + rename ${token}EventCoroutine {} + } if { ($state(status) eq "timeout") || ($state(status) eq "error") || ($state(status) eq "eof") @@ -357,13 +360,7 @@ proc http::KeepSocket {token} { Log #Log pipelined, GRANT read access to $token3 in KeepSocket set socketRdState($connId) $token3 - lassign [fconfigure $state3(sock) -translation] trRead trWrite - fconfigure $state3(sock) -translation [list auto $trWrite] \ - -buffersize $state3(-blocksize) - Log ^D$tk2 begin receiving response - token $token3 - fileevent $state3(sock) readable \ - [list http::Event $state3(sock) $token3] - Log #Log ---- $state3(sock) >> conn to $token3 for HTTP response (a) + ReceiveResponse $token3 # Other pipelined cases. # - The test above ensures that, for the pipelined cases in the two @@ -1602,16 +1599,32 @@ proc http::DoneRequest {token} { # In the pipelined case, connection for reading depends on the # value of socketRdState. # In the nonpipeline case, connection for reading always occurs. - Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response (b) - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list auto $trWrite] \ - -buffersize $state(-blocksize) - Log ^D$tk begin receiving response - token $token - fileevent $sock readable [list http::Event $sock $token] + ReceiveResponse $token } return } +# http::ReceiveResponse +# +# Connects token to its socket for reading. + +proc http::ReceiveResponse {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + + Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list auto $trWrite] \ + -buffersize $state(-blocksize) + Log ^D$tk begin receiving response - token $token + + coroutine ${token}EventCoroutine http::Event $sock $token + fileevent $sock readable ${token}EventCoroutine + return +} + # http::NextPipelinedWrite # # - Connecting a socket to a token for writing is done by this command and by @@ -2247,6 +2260,9 @@ proc http::error {token} { proc http::cleanup {token} { variable $token upvar 0 $token state + if {[info commands ${token}EventCoroutine] ne {}} { + rename ${token}EventCoroutine {} + } if {[info exists state]} { unset state } @@ -2426,447 +2442,452 @@ proc http::Event {sock token} { variable $token upvar 0 $token state set tk [namespace tail $token] + while 1 { + yield + Log ##Log Event call - token $token - Log ##Log Event call - token $token - - if {![info exists state]} { - Log "Event $sock with invalid token '$token' - remote close?" - if {![eof $sock]} { - if {[set d [read $sock]] ne ""} { - Log "WARNING: additional data left on closed socket\ - - token $token" + if {![info exists state]} { + Log "Event $sock with invalid token '$token' - remote close?" + if {![eof $sock]} { + if {[set d [read $sock]] ne ""} { + Log "WARNING: additional data left on closed socket\ + - token $token" + } } + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + return } - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock - return - } - if {$state(state) eq "connecting"} { - Log ##Log - connecting - token $token - if { $state(reusing) - && $state(-pipeline) - && ($state(-timeout) > 0) - && (![info exists state(after)]) - } { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } + if {$state(state) eq "connecting"} { + Log ##Log - connecting - token $token + if { $state(reusing) + && $state(-pipeline) + && ($state(-timeout) > 0) + && (![info exists state(after)]) + } { + set state(after) [after $state(-timeout) \ + [list http::reset $token timeout]] + } + + if {[catch {gets $sock state(http)} nsl]} { + Log "WARNING - if testing, pay special attention to this\ + case (GK) which is seldom executed - token $token" + if {[info exists state(reusing)] && $state(reusing)} { + # The socket was closed at the server end, and closed at + # this end by http::CheckEof. - if {[catch {gets $sock state(http)} nsl]} { - Log "WARNING - if testing, pay special attention to this\ - case (GK) which is seldom executed - token $token" - if {[info exists state(reusing)] && $state(reusing)} { - # The socket was closed at the server end, and closed at - # this end by http::CheckEof. + if {[TestForReplay $token read $nsl c]} { + return + } - if {[TestForReplay $token read $nsl c]} { + # else: + # This is NOT a persistent socket that has been closed since its + # last use. + # If any other requests are in flight or pipelined/queued, they + # will be discarded. + } else { + Log ^X$tk end of response (error) - token $token + Finish $token $nsl + return + } + } elseif {$nsl >= 0} { + Log ##Log - connecting 1 - token $token + set state(state) "header" + } elseif { [eof $sock] + && [info exists state(reusing)] + && $state(reusing) + } { + # The socket was closed at the server end, and we didn't notice. + # This is the first read - where the closure is usually first + # detected. + + if {[TestForReplay $token read {} d]} { return } # else: # This is NOT a persistent socket that has been closed since its # last use. - # If any other requests are in flight or pipelined/queued, they - # will be discarded. + # If any other requests are in flight or pipelined/queued, they will + # be discarded. } else { - Log ^X$tk end of response (error) - token $token - Finish $token $nsl - return + Log ##Log - connecting 2 - token $token + # nsl is -1 so either fblocked (OK) or (eof and not reusing). + # Continue. Any eof is processed at the end of this proc. } - } elseif {$nsl >= 0} { - Log ##Log - connecting 1 - token $token - set state(state) "header" - } elseif { [eof $sock] - && [info exists state(reusing)] - && $state(reusing) - } { - # The socket was closed at the server end, and we didn't notice. - # This is the first read - where the closure is usually first - # detected. - - if {[TestForReplay $token read {} d]} { - return - } - - # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. - } else { - Log ##Log - connecting 2 - token $token - # nsl is -1 so either fblocked (OK) or (eof and not reusing). - # Continue. Any eof is processed at the end of this proc. - } - } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} nhl]} { - Log ##Log header failed - token $token - Log ^X$tk end of response (error) - token $token - Finish $token $nhl - return - } elseif {$nhl == 0} { - Log ##Log header done - token $token - Log ^E$tk end of response headers - token $token - # We have now read all headers - # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if { ($state(http) == "") - || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) - } { - set state(state) "connecting" + } elseif {$state(state) eq "header"} { + if {[catch {gets $sock line} nhl]} { + Log ##Log header failed - token $token + Log ^X$tk end of response (error) - token $token + Finish $token $nhl return - } + } elseif {$nhl == 0} { + Log ##Log header done - token $token + Log ^E$tk end of response headers - token $token + # We have now read all headers + # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 + if { ($state(http) == "") + || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) + } { + set state(state) "connecting" + continue + # This was a "return" in the pre-coroutine code. + } - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "keep-alive") - && ($state(-keepalive)) - && (!$state(reusing)) - && ($state(-pipeline)) - } { - # Response headers received for first request on a persistent - # socket. Now ready for pipelined writes (if any). - # Previous value is $token. It cannot be pending. - set socketWrState($state(socketinfo)) Wready - http::NextPipelinedWrite $token - } + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "keep-alive") + && ($state(-keepalive)) + && (!$state(reusing)) + && ($state(-pipeline)) + } { + # Response headers received for first request on a persistent + # socket. Now ready for pipelined writes (if any). + # Previous value is $token. It cannot be pending. + set socketWrState($state(socketinfo)) Wready + http::NextPipelinedWrite $token + } - # Once a "close" has been signaled, the client MUST NOT send any - # more requests on that connection. - # - # If either the client or the server sends the "close" token in the - # Connection header, that request becomes the last one for the - # connection. - - if { ([info exists state(connection)]) - && ([info exists socketMapping($state(socketinfo))]) - && ($state(connection) eq "close") - && ($state(-keepalive)) - } { - # The server warns that it will close the socket after this - # response. - Log ##Log WARNING - socket will close after response for $token - # Prepare data for a call to ReplayIfClose. - if { ($socketRdQueue($state(socketinfo)) ne {}) - || ($socketWrQueue($state(socketinfo)) ne {}) - || ($socketWrState($state(socketinfo)) ni - [list Wready peNding $token]) + # Once a "close" has been signaled, the client MUST NOT send any + # more requests on that connection. + # + # If either the client or the server sends the "close" token in the + # Connection header, that request becomes the last one for the + # connection. + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ($state(connection) eq "close") + && ($state(-keepalive)) } { - set InFlightW $socketWrState($state(socketinfo)) - if {$InFlightW in [list Wready peNding $token]} { - set InFlightW Wready - } else { - set msg "token ${InFlightW} is InFlightW" - Log ##Log $msg - token $token - } + # The server warns that it will close the socket after this + # response. + Log ##Log WARNING - socket will close after response for $token + # Prepare data for a call to ReplayIfClose. + if { ($socketRdQueue($state(socketinfo)) ne {}) + || ($socketWrQueue($state(socketinfo)) ne {}) + || ($socketWrState($state(socketinfo)) ni + [list Wready peNding $token]) + } { + set InFlightW $socketWrState($state(socketinfo)) + if {$InFlightW in [list Wready peNding $token]} { + set InFlightW Wready + } else { + set msg "token ${InFlightW} is InFlightW" + Log ##Log $msg - token $token + } - set socketPlayCmd($state(socketinfo)) \ - [list ReplayIfClose $InFlightW \ - $socketRdQueue($state(socketinfo)) \ - $socketWrQueue($state(socketinfo))] - - # - All tokens are preserved for re-use by ReplayCore. - # - Queues are preserved in case of Finish with error, but - # are not used for anything else because socketClosing(*) - # is set below. - # - Cancel the state(after) timeout events. - foreach tokenElement $socketRdQueue($state(socketinfo)) { - if {[info exists ${tokenElement}(after)]} { - after cancel [set ${tokenElement}(after)] - unset ${tokenElement}(after) + set socketPlayCmd($state(socketinfo)) \ + [list ReplayIfClose $InFlightW \ + $socketRdQueue($state(socketinfo)) \ + $socketWrQueue($state(socketinfo))] + + # - All tokens are preserved for re-use by ReplayCore. + # - Queues are preserved in case of Finish with error, but + # are not used for anything else because socketClosing(*) + # is set below. + # - Cancel the state(after) timeout events. + foreach tokenElement $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenElement}(after)]} { + after cancel [set ${tokenElement}(after)] + unset ${tokenElement}(after) + } } + + } else { + set socketPlayCmd($state(socketinfo)) \ + {ReplayIfClose Wready {} {}} } - } else { - set socketPlayCmd($state(socketinfo)) \ - {ReplayIfClose Wready {} {}} + # Do not allow further connections on this socket. + set socketClosing($state(socketinfo)) 1 } - # Do not allow further connections on this socket. - set socketClosing($state(socketinfo)) 1 - } - - set state(state) body + set state(state) body - # If doing a HEAD, then we won't get any body - if {$state(-validate)} { - Log ^F$tk end of response for HEAD request - token $token - set state(state) complete - Eot $token - return - } + # If doing a HEAD, then we won't get any body + if {$state(-validate)} { + Log ^F$tk end of response for HEAD request - token $token + set state(state) complete + Eot $token + return + } - # - For non-chunked transfer we may have no body - in this case we - # may get no further file event if the connection doesn't close - # and no more data is sent. We can tell and must finish up now - - # not later - the alternative would be to wait until the server - # times out. - # - In this case, the server has NOT told the client it will close - # the connection, AND it has NOT indicated the resource length - # EITHER by setting the Content-Length (totalsize) OR by using - # chunked Transer-Encoding. - # - Do not worry here about the case (Connection: close) because - # the server should close the connection. - # - IF (NOT Connection: close) AND (NOT chunked encoding) AND - # (totalsize == 0). - - if { (!( [info exists state(connection)] - && ($state(connection) eq "close") - ) - ) - && (![info exists state(transfer)]) - && ($state(totalsize) == 0) - } { - set msg {body size is 0 and no events likely - complete} - Log "$msg - token $token" - set msg {(length unknown, set to 0)} - Log ^F$tk end of response body {*}$msg - token $token - set state(state) complete - Eot $token - return - } + # - For non-chunked transfer we may have no body - in this case we + # may get no further file event if the connection doesn't close + # and no more data is sent. We can tell and must finish up now - + # not later - the alternative would be to wait until the server + # times out. + # - In this case, the server has NOT told the client it will close + # the connection, AND it has NOT indicated the resource length + # EITHER by setting the Content-Length (totalsize) OR by using + # chunked Transer-Encoding. + # - Do not worry here about the case (Connection: close) because + # the server should close the connection. + # - IF (NOT Connection: close) AND (NOT chunked encoding) AND + # (totalsize == 0). + + if { (!( [info exists state(connection)] + && ($state(connection) eq "close") + ) + ) + && (![info exists state(transfer)]) + && ($state(totalsize) == 0) + } { + set msg {body size is 0 and no events likely - complete} + Log "$msg - token $token" + set msg {(length unknown, set to 0)} + Log ^F$tk end of response body {*}$msg - token $token + set state(state) complete + Eot $token + return + } - # We have to use binary translation to count bytes properly. - lassign [fconfigure $sock -translation] trRead trWrite - fconfigure $sock -translation [list binary $trWrite] + # We have to use binary translation to count bytes properly. + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list binary $trWrite] - if { - $state(-binary) || [IsBinaryContentType $state(type)] - } { - # Turn off conversions for non-text data. - set state(binary) 1 - } - if {[info exists state(-channel)]} { - if {$state(binary) || [llength [ContentEncoding $token]]} { - fconfigure $state(-channel) -translation binary - } - if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies. - fileevent $sock readable {} - CopyStart $sock $token - return + if { + $state(-binary) || [IsBinaryContentType $state(type)] + } { + # Turn off conversions for non-text data. + set state(binary) 1 } - } - } elseif {$nhl > 0} { - # Process header lines. - Log ##Log header - token $token - $line - if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { - switch -- [string tolower $key] { - content-type { - set state(type) [string trim [string tolower $value]] - # Grab the optional charset information. - if {[regexp -nocase \ - {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ - $state(type) -> cs]} { - set state(charset) [string map {{\"} \"} $cs] - } else { - regexp -nocase {charset\s*=\s*(\S+?);?} \ - $state(type) -> state(charset) - } + if {[info exists state(-channel)]} { + if {$state(binary) || [llength [ContentEncoding $token]]} { + fconfigure $state(-channel) -translation binary } - content-length { - set state(totalsize) [string trim $value] + if {![info exists state(-handler)]} { + # Initiate a sequence of background fcopies. + fileevent $sock readable {} + rename ${token}EventCoroutine {} + CopyStart $sock $token + return } - content-encoding { - set state(coding) [string trim $value] - } - transfer-encoding { - set state(transfer) \ - [string trim [string tolower $value]] - } - proxy-connection - - connection { - set state(connection) \ - [string trim [string tolower $value]] + } + } elseif {$nhl > 0} { + # Process header lines. + Log ##Log header - token $token - $line + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + switch -- [string tolower $key] { + content-type { + set state(type) [string trim [string tolower $value]] + # Grab the optional charset information. + if {[regexp -nocase \ + {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ + $state(type) -> cs]} { + set state(charset) [string map {{\"} \"} $cs] + } else { + regexp -nocase {charset\s*=\s*(\S+?);?} \ + $state(type) -> state(charset) + } + } + content-length { + set state(totalsize) [string trim $value] + } + content-encoding { + set state(coding) [string trim $value] + } + transfer-encoding { + set state(transfer) \ + [string trim [string tolower $value]] + } + proxy-connection - + connection { + set state(connection) \ + [string trim [string tolower $value]] + } } + lappend state(meta) $key [string trim $value] } - lappend state(meta) $key [string trim $value] } - } - } else { - # Now reading body - Log ##Log body - token $token - if {[catch { - if {[info exists state(-handler)]} { - set n [eval $state(-handler) [list $sock $token]] - Log ##Log handler $n - token $token - # N.B. the protocol has been set to 1.0 because the -handler - # logic is not expected to handle chunked encoding. - # FIXME allow -handler with 1.1 on dechunked stacked channel. - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection - i.e. eof is not an error. - set state(state) complete - } - if {![string is integer -strict $n]} { - if 1 { - # Do not tolerate bad -handler - fail with error status. - set msg {the -handler command for http::geturl must\ - return an integer (the number of bytes read)} - Log ^X$tk end of response (handler error) - token $token - Eot $token $msg - } else { - # Tolerate the bad -handler, and continue. The penalty: - # (a) Because the handler returns nonsense, we know the - # transfer is complete only when the server closes - # the connection - i.e. eof is not an error. - # (b) http::size will not be accurate. - # (c) The transaction is already downgraded to 1.0 to - # avoid chunked transfer encoding. It MUST also be - # forced to "Connection: close" or the HTTP/1.0 - # equivalent; or it MUST fail (as above) if the - # server sends "Connection: keep-alive" or the - # HTTP/1.0 equivalent. - set n 0 + } else { + # Now reading body + Log ##Log body - token $token + if {[catch { + if {[info exists state(-handler)]} { + set n [eval $state(-handler) [list $sock $token]] + Log ##Log handler $n - token $token + # N.B. the protocol has been set to 1.0 because the -handler + # logic is not expected to handle chunked encoding. + # FIXME allow -handler with 1.1 on dechunked stacked channel. + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection - i.e. eof is not an error. set state(state) complete } - } else { - } - } elseif {[info exists state(transfer_final)]} { - set line [getTextLine $sock] - set n [string length $line] - set state(state) complete - if {$n > 0} { - # - HTTP trailers (late response headers) are permitted by - # Chunked Transfer-Encoding, and can be safely ignored. - # - Do not count these bytes in the total received for the - # response body. - Log "trailer of $n bytes after final chunk - token $token" - append state(transfer_final) $line - set n 0 - } else { - Log ^F$tk end of response body (chunked) - token $token - Log "final chunk part - token $token" - Eot $token - } - } elseif { [info exists state(transfer)] - && ($state(transfer) eq "chunked") - } { - Log ##Log chunked - token $token - set size 0 - set hexLenChunk [getTextLine $sock] - #set ntl [string length $hexLenChunk] - if {[string trim $hexLenChunk] ne ""} { - scan $hexLenChunk %x size - if {$size != 0} { - Log ##Log chunk-measure $size - token $token - set bl [fconfigure $sock -blocking] - fconfigure $sock -blocking 1 - set chunk [read $sock $size] - fconfigure $sock -blocking $bl - set n [string length $chunk] - if {$n >= 0} { - append state(body) $chunk - incr state(log_size) [string length $chunk] - Log ##Log chunk $n cumul $state(log_size) - token $token + if {![string is integer -strict $n]} { + if 1 { + # Do not tolerate bad -handler - fail with error status. + set msg {the -handler command for http::geturl must\ + return an integer (the number of bytes read)} + Log ^X$tk end of response (handler error) - token $token + Eot $token $msg + } else { + # Tolerate the bad -handler, and continue. The penalty: + # (a) Because the handler returns nonsense, we know the + # transfer is complete only when the server closes + # the connection - i.e. eof is not an error. + # (b) http::size will not be accurate. + # (c) The transaction is already downgraded to 1.0 to + # avoid chunked transfer encoding. It MUST also be + # forced to "Connection: close" or the HTTP/1.0 + # equivalent; or it MUST fail (as above) if the + # server sends "Connection: keep-alive" or the + # HTTP/1.0 equivalent. + set n 0 + set state(state) complete } - if {$size != [string length $chunk]} { - Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be $size -\ - token $token" + } else { + } + } elseif {[info exists state(transfer_final)]} { + set line [getTextLine $sock] + set n [string length $line] + set state(state) complete + if {$n > 0} { + # - HTTP trailers (late response headers) are permitted by + # Chunked Transfer-Encoding, and can be safely ignored. + # - Do not count these bytes in the total received for the + # response body. + Log "trailer of $n bytes after final chunk - token $token" + append state(transfer_final) $line + set n 0 + } else { + Log ^F$tk end of response body (chunked) - token $token + Log "final chunk part - token $token" + Eot $token + } + } elseif { [info exists state(transfer)] + && ($state(transfer) eq "chunked") + } { + Log ##Log chunked - token $token + set size 0 + set hexLenChunk [getTextLine $sock] + #set ntl [string length $hexLenChunk] + if {[string trim $hexLenChunk] ne ""} { + scan $hexLenChunk %x size + if {$size != 0} { + Log ##Log chunk-measure $size - token $token + set chunk [BlockingRead $sock $size] + set n [string length $chunk] + if {$n >= 0} { + append state(body) $chunk + incr state(log_size) [string length $chunk] + Log ##Log chunk $n cumul $state(log_size) - token $token + } + if {$size != [string length $chunk]} { + Log "WARNING: mis-sized chunk:\ + was [string length $chunk], should be $size -\ + token $token" + set n 0 + set state(connection) close + Log ^X$tk end of response (chunk error) \ + - token $token + set msg {error in chunked encoding - fetch\ + terminated} + Eot $token $msg + } + # CRLF that follows chunk: + getTextLine $sock + } else { set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) \ - - token $token - set msg {error in chunked encoding - fetch\ - terminated} - Eot $token $msg + set state(transfer_final) {} } - # CRLF that follows chunk: - getTextLine $sock } else { + # Line expected to hold chunk length is empty. + Log ##Log bad-chunk-measure - token $token set n 0 - set state(transfer_final) {} + set state(connection) close + Log ^X$tk end of response (chunk error) - token $token + Eot $token {error in chunked encoding - fetch terminated} } } else { - # Line expected to hold chunk length is empty. - Log ##Log bad-chunk-measure - token $token - set n 0 - set state(connection) close - Log ^X$tk end of response (chunk error) - token $token - Eot $token {error in chunked encoding - fetch terminated} - } - } else { - Log ##Log unchunked - token $token - if {$state(totalsize) == 0} { - # We know the transfer is complete only when the server - # closes the connection. - set state(state) complete - set reqSize $state(-blocksize) - } else { - # Ask for the whole of the unserved response-body. - # This works around a problem with a tls::socket - for https - # in keep-alive mode, and a request for $state(-blocksize) - # bytes, the last part of the resource does not get read - # until the server times out. - set reqSize [expr {$state(totalsize) - $state(currentsize)}] - - # The workaround fails if reqSize is - # capped at $state(-blocksize). - # set reqSize [expr {min($reqSize, $state(-blocksize))}] - } - set c $state(currentsize) - set t $state(totalsize) - Log ##Log non-chunk currentsize $c of totalsize $t - token $token - set block [read $sock $reqSize] - set n [string length $block] - if {$n >= 0} { - append state(body) $block - Log ##Log non-chunk [string length $state(body)] - token $token - } - } - # This calculation uses n from the -handler, chunked, or unchunked - # case as appropriate. - if {[info exists state]} { - if {$n >= 0} { - incr state(currentsize) $n + Log ##Log unchunked - token $token + if {$state(totalsize) == 0} { + # We know the transfer is complete only when the server + # closes the connection. + set state(state) complete + set reqSize $state(-blocksize) + } else { + # Ask for the whole of the unserved response-body. + # This works around a problem with a tls::socket - for https + # in keep-alive mode, and a request for $state(-blocksize) + # bytes, the last part of the resource does not get read + # until the server times out. + set reqSize [expr {$state(totalsize) - $state(currentsize)}] + + # The workaround fails if reqSize is + # capped at $state(-blocksize). + # set reqSize [expr {min($reqSize, $state(-blocksize))}] + } set c $state(currentsize) set t $state(totalsize) - Log ##Log another $n currentsize $c totalsize $t - token $token + Log ##Log non-chunk currentsize $c of totalsize $t - token $token + set block [read $sock $reqSize] + set n [string length $block] + if {$n >= 0} { + append state(body) $block + Log ##Log non-chunk [string length $state(body)] - token $token + } } - # If Content-Length - check for end of data. - if { - ($state(totalsize) > 0) - && ($state(currentsize) >= $state(totalsize)) - } { - Log ^F$tk end of response body (unchunked) - token $token - set state(state) complete - Eot $token + # This calculation uses n from the -handler, chunked, or unchunked + # case as appropriate. + if {[info exists state]} { + if {$n >= 0} { + incr state(currentsize) $n + set c $state(currentsize) + set t $state(totalsize) + Log ##Log another $n currentsize $c totalsize $t - token $token + } + # If Content-Length - check for end of data. + if { + ($state(totalsize) > 0) + && ($state(currentsize) >= $state(totalsize)) + } { + Log ^F$tk end of response body (unchunked) - token $token + set state(state) complete + Eot $token + } + } + } err]} { + Log ^X$tk end of response (error ${err}) - token $token + Finish $token $err + return + } else { + if {[info exists state(-progress)]} { + eval $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] } - } - } err]} { - Log ^X$tk end of response (error ${err}) - token $token - Finish $token $err - return - } else { - if {[info exists state(-progress)]} { - eval $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] } } - } - # catch as an Eot above may have closed the socket already - # $state(state) may be connecting, header, body, or complete - if {![catch {eof $sock} eof] && $eof} { - Log ##Log eof - token $token - if {[info exists $token]} { - set state(connection) close - if {$state(state) eq "complete"} { - # This includes all cases in which the transaction - # can be completed by eof. - # The value "complete" is set only in http::Event, and it is - # used only in the test above. - Log ^F$tk end of response body (unchunked, eof) - token $token - Eot $token + # catch as an Eot above may have closed the socket already + # $state(state) may be connecting, header, body, or complete + if {![set cc [catch {eof $sock} eof]] && $eof} { + Log ##Log eof - token $token + if {[info exists $token]} { + set state(connection) close + if {$state(state) eq "complete"} { + # This includes all cases in which the transaction + # can be completed by eof. + # The value "complete" is set only in http::Event, and it is + # used only in the test above. + Log ^F$tk end of response body (unchunked, eof) - token $token + Eot $token + } else { + # Premature eof. + Log ^X$tk end of response (unexpected eof) - token $token + Eot $token eof + } } else { - # Premature eof. - Log ^X$tk end of response (unexpected eof) - token $token - Eot $token eof + # open connection closed on a token that has been cleaned up. + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock } + } elseif {$cc} { + return } else { - # open connection closed on a token that has been cleaned up. - Log ^X$tk end of response (token error) - token $token - CloseSocket $sock + # Not eof, continue and yield. } } return @@ -2970,18 +2991,55 @@ proc http::IsBinaryContentType {type} { # Results: # The line of text, without trailing newline -# FIXME get rid of blocking - proc http::getTextLine {sock} { set tr [fconfigure $sock -translation] lassign $tr trRead trWrite - set bl [fconfigure $sock -blocking] - fconfigure $sock -translation [list crlf $trWrite] -blocking 1 - set r [gets $sock] - fconfigure $sock -translation $tr -blocking $bl + fconfigure $sock -translation [list crlf $trWrite] + set r [BlockingGets $sock] + fconfigure $sock -translation $tr return $r } +# http::BlockingRead +# +# Replacement for a blocking read. +# The caller must be a coroutine. + +proc http::BlockingRead {sock size} { + if {$size < 1} { + return + } + set result {} + while 1 { + set need [expr {$size - [string length $result]}] + set block [read $sock $need] + set eof [eof $sock] + append result $block + if {[string length $result] >= $size || $eof} { + return $result + } else { + yield + } + } +} + +# http::BlockingGets +# +# Replacement for a blocking gets. +# The caller must be a coroutine. + +proc http::BlockingGets {sock} { + while 1 { + set count [gets $sock line] + set eof [eof $sock] + if {$count > -1 || $eof} { + return $line + } else { + yield + } + } +} + # http::CopyStart # # Error handling wrapper around fcopy -- cgit v0.12 From 6bc8c27b7f2b94c8b35b1a7533fb19cb2f788fbd Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 4 Apr 2018 13:37:37 +0000 Subject: Restore most lines to 80 columns --- library/http/http.tcl | 147 ++++++++++++++++++++++++++++---------------------- 1 file changed, 83 insertions(+), 64 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 77a2a43..28bb13d 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -2420,7 +2420,9 @@ proc http::Write {token} { # http::Event # -# Handle input on the socket +# Handle input on the socket. This command is the core of +# the coroutine commands ${token}EventCoroutine that are +# bound to "fileevent $sock readable" and process input. # # Arguments # sock The socket receiving input. @@ -2481,10 +2483,10 @@ proc http::Event {sock token} { } # else: - # This is NOT a persistent socket that has been closed since its - # last use. - # If any other requests are in flight or pipelined/queued, they - # will be discarded. + # This is NOT a persistent socket that has been closed since + # its last use. + # If any other requests are in flight or pipelined/queued, + # they will be discarded. } else { Log ^X$tk end of response (error) - token $token Finish $token $nsl @@ -2508,8 +2510,8 @@ proc http::Event {sock token} { # else: # This is NOT a persistent socket that has been closed since its # last use. - # If any other requests are in flight or pipelined/queued, they will - # be discarded. + # If any other requests are in flight or pipelined/queued, they + # will be discarded. } else { Log ##Log - connecting 2 - token $token # nsl is -1 so either fblocked (OK) or (eof and not reusing). @@ -2541,9 +2543,10 @@ proc http::Event {sock token} { && (!$state(reusing)) && ($state(-pipeline)) } { - # Response headers received for first request on a persistent - # socket. Now ready for pipelined writes (if any). - # Previous value is $token. It cannot be pending. + # Response headers received for first request on a + # persistent socket. Now ready for pipelined writes (if + # any). + # Previous value is $token. It cannot be "pending". set socketWrState($state(socketinfo)) Wready http::NextPipelinedWrite $token } @@ -2551,9 +2554,9 @@ proc http::Event {sock token} { # Once a "close" has been signaled, the client MUST NOT send any # more requests on that connection. # - # If either the client or the server sends the "close" token in the - # Connection header, that request becomes the last one for the - # connection. + # If either the client or the server sends the "close" token in + # the Connection header, that request becomes the last one for + # the connection. if { ([info exists state(connection)]) && ([info exists socketMapping($state(socketinfo))]) @@ -2583,14 +2586,14 @@ proc http::Event {sock token} { $socketWrQueue($state(socketinfo))] # - All tokens are preserved for re-use by ReplayCore. - # - Queues are preserved in case of Finish with error, but - # are not used for anything else because socketClosing(*) - # is set below. + # - Queues are preserved in case of Finish with error, + # but are not used for anything else because + # socketClosing(*) is set below. # - Cancel the state(after) timeout events. - foreach tokenElement $socketRdQueue($state(socketinfo)) { - if {[info exists ${tokenElement}(after)]} { - after cancel [set ${tokenElement}(after)] - unset ${tokenElement}(after) + foreach tokenVal $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenVal}(after)]} { + after cancel [set ${tokenVal}(after)] + unset ${tokenVal}(after) } } @@ -2613,15 +2616,15 @@ proc http::Event {sock token} { return } - # - For non-chunked transfer we may have no body - in this case we - # may get no further file event if the connection doesn't close - # and no more data is sent. We can tell and must finish up now - - # not later - the alternative would be to wait until the server - # times out. - # - In this case, the server has NOT told the client it will close - # the connection, AND it has NOT indicated the resource length - # EITHER by setting the Content-Length (totalsize) OR by using - # chunked Transer-Encoding. + # - For non-chunked transfer we may have no body - in this case + # we may get no further file event if the connection doesn't + # close and no more data is sent. We can tell and must finish + # up now - not later - the alternative would be to wait until + # the server times out. + # - In this case, the server has NOT told the client it will + # close the connection, AND it has NOT indicated the resource + # length EITHER by setting the Content-Length (totalsize) OR + # by using chunked Transfer-Encoding. # - Do not worry here about the case (Connection: close) because # the server should close the connection. # - IF (NOT Connection: close) AND (NOT chunked encoding) AND @@ -2710,7 +2713,7 @@ proc http::Event {sock token} { Log ##Log handler $n - token $token # N.B. the protocol has been set to 1.0 because the -handler # logic is not expected to handle chunked encoding. - # FIXME allow -handler with 1.1 on dechunked stacked channel. + # FIXME Allow -handler with 1.1 on dechunked stacked chan. if {$state(totalsize) == 0} { # We know the transfer is complete only when the server # closes the connection - i.e. eof is not an error. @@ -2718,23 +2721,29 @@ proc http::Event {sock token} { } if {![string is integer -strict $n]} { if 1 { - # Do not tolerate bad -handler - fail with error status. + # Do not tolerate bad -handler - fail with error + # status. set msg {the -handler command for http::geturl must\ - return an integer (the number of bytes read)} - Log ^X$tk end of response (handler error) - token $token + return an integer (the number of bytes\ + read)} + Log ^X$tk end of response (handler error) -\ + token $token Eot $token $msg } else { - # Tolerate the bad -handler, and continue. The penalty: - # (a) Because the handler returns nonsense, we know the - # transfer is complete only when the server closes - # the connection - i.e. eof is not an error. + # Tolerate the bad -handler, and continue. The + # penalty: + # (a) Because the handler returns nonsense, we know + # the transfer is complete only when the server + # closes the connection - i.e. eof is not an + # error. # (b) http::size will not be accurate. - # (c) The transaction is already downgraded to 1.0 to - # avoid chunked transfer encoding. It MUST also be - # forced to "Connection: close" or the HTTP/1.0 - # equivalent; or it MUST fail (as above) if the - # server sends "Connection: keep-alive" or the - # HTTP/1.0 equivalent. + # (c) The transaction is already downgraded to 1.0 + # to avoid chunked transfer encoding. It MUST + # also be forced to "Connection: close" or the + # HTTP/1.0 equivalent; or it MUST fail (as + # above) if the server sends + # "Connection: keep-alive" or the HTTP/1.0 + # equivalent. set n 0 set state(state) complete } @@ -2745,11 +2754,13 @@ proc http::Event {sock token} { set n [string length $line] set state(state) complete if {$n > 0} { - # - HTTP trailers (late response headers) are permitted by - # Chunked Transfer-Encoding, and can be safely ignored. - # - Do not count these bytes in the total received for the - # response body. - Log "trailer of $n bytes after final chunk - token $token" + # - HTTP trailers (late response headers) are permitted + # by Chunked Transfer-Encoding, and can be safely + # ignored. + # - Do not count these bytes in the total received for + # the response body. + Log "trailer of $n bytes after final chunk -\ + token $token" append state(transfer_final) $line set n 0 } else { @@ -2773,12 +2784,13 @@ proc http::Event {sock token} { if {$n >= 0} { append state(body) $chunk incr state(log_size) [string length $chunk] - Log ##Log chunk $n cumul $state(log_size) - token $token + Log ##Log chunk $n cumul $state(log_size) -\ + token $token } if {$size != [string length $chunk]} { Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be $size -\ - token $token" + was [string length $chunk], should be\ + $size - token $token" set n 0 set state(connection) close Log ^X$tk end of response (chunk error) \ @@ -2799,7 +2811,8 @@ proc http::Event {sock token} { set n 0 set state(connection) close Log ^X$tk end of response (chunk error) - token $token - Eot $token {error in chunked encoding - fetch terminated} + Eot $token {error in chunked encoding -\ + fetch terminated} } } else { Log ##Log unchunked - token $token @@ -2810,11 +2823,12 @@ proc http::Event {sock token} { set reqSize $state(-blocksize) } else { # Ask for the whole of the unserved response-body. - # This works around a problem with a tls::socket - for https - # in keep-alive mode, and a request for $state(-blocksize) - # bytes, the last part of the resource does not get read - # until the server times out. - set reqSize [expr {$state(totalsize) - $state(currentsize)}] + # This works around a problem with a tls::socket - for + # https in keep-alive mode, and a request for + # $state(-blocksize) bytes, the last part of the + # resource does not get read until the server times out. + set reqSize [expr { $state(totalsize) + - $state(currentsize)}] # The workaround fails if reqSize is # capped at $state(-blocksize). @@ -2822,29 +2836,33 @@ proc http::Event {sock token} { } set c $state(currentsize) set t $state(totalsize) - Log ##Log non-chunk currentsize $c of totalsize $t - token $token + Log ##Log non-chunk currentsize $c of totalsize $t -\ + token $token set block [read $sock $reqSize] set n [string length $block] if {$n >= 0} { append state(body) $block - Log ##Log non-chunk [string length $state(body)] - token $token + Log ##Log non-chunk [string length $state(body)] -\ + token $token } } - # This calculation uses n from the -handler, chunked, or unchunked - # case as appropriate. + # This calculation uses n from the -handler, chunked, or + # unchunked case as appropriate. if {[info exists state]} { if {$n >= 0} { incr state(currentsize) $n set c $state(currentsize) set t $state(totalsize) - Log ##Log another $n currentsize $c totalsize $t - token $token + Log ##Log another $n currentsize $c totalsize $t -\ + token $token } # If Content-Length - check for end of data. if { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) } { - Log ^F$tk end of response body (unchunked) - token $token + Log ^F$tk end of response body (unchunked) -\ + token $token set state(state) complete Eot $token } @@ -2872,7 +2890,8 @@ proc http::Event {sock token} { # can be completed by eof. # The value "complete" is set only in http::Event, and it is # used only in the test above. - Log ^F$tk end of response body (unchunked, eof) - token $token + Log ^F$tk end of response body (unchunked, eof) -\ + token $token Eot $token } else { # Premature eof. -- cgit v0.12 From d690b847384c4c4ea77254292ac7e36a71b4867d Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 13 Apr 2018 15:41:00 +0000 Subject: Improve detection and reporting of TLS errors. New command http::registerError to assist the latter. Ensure that http::cleanup cancels any timeout event if not already done. Add comments on non-blocking read/gets. --- library/http/http.tcl | 80 ++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 66 insertions(+), 14 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 28bb13d..e0382e7 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -128,13 +128,13 @@ namespace eval http { set defaultKeepalive 0 } - namespace export geturl config reset wait formatQuery register unregister - # Useful, but not exported: data size status code cleanup error meta ncode, - # mapReply, init. Comments suggest that "init" can be used for - # re-initialisation, although it is undocumented. - # - # Not exported, probably should be upper-case initial letter as part - # of the internals: getTextLine make-transformation-chunked + namespace export geturl config reset wait formatQuery + namespace export register unregister registerError + # - Useful, but not exported: data, size, status, code, cleanup, error, + # meta, ncode, mapReply, init. Comments suggest that "init" can be used + # for re-initialisation, although the command is undocumented. + # - Not exported, probably should be upper-case initial letter as part + # of the internals: getTextLine, make-transformation-chunked. } # http::Log -- @@ -1470,6 +1470,11 @@ proc http::Connected {token proto phost srvurl} { puts $sock "Content-Length: $state(querylength)" } puts $sock "" + flush $sock + # Flush flushes the error in the https case with a bad handshake: + # else the socket never becomes writable again, and hangs until + # timeout (if any). + lassign [fconfigure $sock -translation] trRead trWrite fconfigure $sock -translation [list $trRead binary] fileevent $sock writable [list http::Write $token] @@ -1496,8 +1501,9 @@ proc http::Connected {token proto phost srvurl} { } } err]} { - # The socket probably was never connected, or the connection dropped - # later. + # The socket probably was never connected, OR the connection dropped + # later, OR https handshake error, which may be discovered as late as + # the "flush" command above... Log "WARNING - if testing, pay special attention to this\ case (GI) which is seldom executed - token $token" if {[info exists state(reusing)] && $state(reusing)} { @@ -1515,7 +1521,14 @@ proc http::Connected {token proto phost srvurl} { # If any other requests are in flight or pipelined/queued, they will # be discarded. } elseif {$state(status) eq ""} { - Finish $token {failed to re-use socket} + # ...https handshake errors come here. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg {failed to use socket} + } else { + } + Finish $token $msg } elseif {$state(status) ne "error"} { Finish $token $err } else { @@ -1526,6 +1539,35 @@ proc http::Connected {token proto phost srvurl} { return } +# http::registerError +# +# Called (for example when processing TclTLS activity) to register +# an error for a connection on a specific socket. This helps +# http::Connected to deliver meaningful error messages, e.g. when a TLS +# certificate fails verification. +# +# Usage: http::registerError socket ?newValue? +# +# "set" semantics, except that a "get" (a call without a new value) for a +# non-existent socket returns {}, not an error. + +proc http::registerError {sock args} { + variable registeredErrors + + if { ([llength $args] == 0) + && (![info exists registeredErrors($sock)]) + } { + return + } elseif { ([llength $args] == 1) + && ([lindex $args 0] eq {}) + } { + unset -nocomplain registeredErrors($sock) + return + } + set registeredErrors($sock) {*}$args + # N.B. Implicit Return +} + # http::DoneRequest -- # # Command called when a request has been sent. It will arrange the @@ -2263,6 +2305,10 @@ proc http::cleanup {token} { if {[info commands ${token}EventCoroutine] ne {}} { rename ${token}EventCoroutine {} } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } if {[info exists state]} { unset state } @@ -2750,6 +2796,7 @@ proc http::Event {sock token} { } else { } } elseif {[info exists state(transfer_final)]} { + # This code forgives EOF in place of the final CRLF. set line [getTextLine $sock] set n [string length $line] set state(state) complete @@ -2799,14 +2846,15 @@ proc http::Event {sock token} { terminated} Eot $token $msg } - # CRLF that follows chunk: + # CRLF that follows chunk. + # If eof, this is handled at the end of this proc. getTextLine $sock } else { set n 0 set state(transfer_final) {} } } else { - # Line expected to hold chunk length is empty. + # Line expected to hold chunk length is empty, or eof. Log ##Log bad-chunk-measure - token $token set n 0 set state(connection) close @@ -3001,8 +3049,10 @@ proc http::IsBinaryContentType {type} { # http::getTextLine -- # -# Get one line with the stream in blocking crlf mode -# Used if Transfer-Encoding is chunked +# Get one line with the stream in crlf mode. +# Used if Transfer-Encoding is chunked. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. # # Arguments # sock The socket receiving input. @@ -3046,6 +3096,8 @@ proc http::BlockingRead {sock size} { # # Replacement for a blocking gets. # The caller must be a coroutine. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. proc http::BlockingGets {sock} { while 1 { -- cgit v0.12 From 4588d7300e53e7403a693eedb0d10d54efccb972 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 13 Apr 2018 15:48:13 +0000 Subject: Restore Tcl 8+4 tab convention --- library/http/http.tcl | 56 +++++++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index e0382e7..30b69e6 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -256,7 +256,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(status) "error" } if {[info commands ${token}EventCoroutine] ne {}} { - rename ${token}EventCoroutine {} + rename ${token}EventCoroutine {} } if { ($state(status) eq "timeout") || ($state(status) eq "error") @@ -333,10 +333,10 @@ proc http::KeepSocket {token} { if {$TEST_EOF} { # ONLY for testing reaction to server eof. # No server timeouts will be caught. - catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) readable {}} } else { - # Normal operation. - # Test constraint normalEof. + # Normal operation. + # Test constraint normalEof. } if { [info exists state(socketinfo)] @@ -1555,14 +1555,14 @@ proc http::registerError {sock args} { variable registeredErrors if { ([llength $args] == 0) - && (![info exists registeredErrors($sock)]) + && (![info exists registeredErrors($sock)]) } { - return + return } elseif { ([llength $args] == 1) - && ([lindex $args 0] eq {}) + && ([lindex $args 0] eq {}) } { - unset -nocomplain registeredErrors($sock) - return + unset -nocomplain registeredErrors($sock) + return } set registeredErrors($sock) {*}$args # N.B. Implicit Return @@ -2303,7 +2303,7 @@ proc http::cleanup {token} { variable $token upvar 0 $token state if {[info commands ${token}EventCoroutine] ne {}} { - rename ${token}EventCoroutine {} + rename ${token}EventCoroutine {} } if {[info exists state(after)]} { after cancel $state(after) @@ -2876,7 +2876,7 @@ proc http::Event {sock token} { # $state(-blocksize) bytes, the last part of the # resource does not get read until the server times out. set reqSize [expr { $state(totalsize) - - $state(currentsize)}] + - $state(currentsize)}] # The workaround fails if reqSize is # capped at $state(-blocksize). @@ -3076,19 +3076,19 @@ proc http::getTextLine {sock} { proc http::BlockingRead {sock size} { if {$size < 1} { - return + return } set result {} while 1 { - set need [expr {$size - [string length $result]}] - set block [read $sock $need] - set eof [eof $sock] - append result $block - if {[string length $result] >= $size || $eof} { - return $result - } else { - yield - } + set need [expr {$size - [string length $result]}] + set block [read $sock $need] + set eof [eof $sock] + append result $block + if {[string length $result] >= $size || $eof} { + return $result + } else { + yield + } } } @@ -3101,13 +3101,13 @@ proc http::BlockingRead {sock size} { proc http::BlockingGets {sock} { while 1 { - set count [gets $sock line] - set eof [eof $sock] - if {$count > -1 || $eof} { - return $line - } else { - yield - } + set count [gets $sock line] + set eof [eof $sock] + if {$count > -1 || $eof} { + return $line + } else { + yield + } } } -- cgit v0.12 From 3771e638b05a4c75d1222ee7653e01cd2289643e Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 20 Apr 2018 20:06:30 +0000 Subject: Document the new proc http::registerError in http.n --- doc/http.n | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/http.n b/doc/http.n index 2dae77e..e788022 100644 --- a/doc/http.n +++ b/doc/http.n @@ -44,6 +44,8 @@ http \- Client-side implementation of the HTTP/1.1 protocol .sp \fB::http::register \fIproto port command\fR .sp +\fB::http::registerError \fIport\fR ?\fImessage\fR? +.sp \fB::http::unregister \fIproto\fR .BE .SH DESCRIPTION @@ -454,6 +456,17 @@ set token [::http::geturl https://my.secure.site/] .CE .RE .TP +\fB::http::registerError\fR \fIport\fR ?\fImessage\fR? +. +This procedure allows a registered protocol handler to deliver an error +message for use by \fBhttp\fR. Calling this command does not raise an +error. The command is useful when a registered protocol detects an problem +(for example, an invalid TLS certificate) that will cause an error to +propagate to \fBhttp\fR. The command allows \fBhttp\fR to provide a +precise error message rather than a general one. The command returns the +value provided by the last call with argument \fImessage\fR, or the empty +string if no such call has been made. +.TP \fB::http::unregister\fR \fIproto\fR . This procedure unregisters a protocol handler that was previously -- cgit v0.12 From b169c964e611847319cc92875f653466939bcb43 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 21 Apr 2018 13:31:16 +0000 Subject: Amend httpPipeline.test tests to use stdout not stderr, and thus avoid the report {Test files exiting with errors} even when all tests pass. --- tests/httpTest.tcl | 16 ++++++++-------- tests/httpTestScript.tcl | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 38ba43f..9cd7a5d 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -25,7 +25,7 @@ package require http namespace eval ::http { variable TestStartTimeInMs [clock milliseconds] - catch {puts stderr "Start time (zero ms) is $TestStartTimeInMs"} + catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"} } namespace eval ::httpTest { @@ -35,15 +35,15 @@ namespace eval ::httpTest { -verbose 0 -dotted 1 } - # -verbose - 0 quiet 1 write to stderr 2 write more + # -verbose - 0 quiet 1 write to stdout 2 write more # -dotted - (boolean) use dots for absences in lists of transactions } proc httpTest::Puts {txt} { variable testOptions if {$testOptions(-verbose) > 0} { - puts stderr $txt - flush stderr + puts stdout $txt + flush stdout } return } @@ -53,7 +53,7 @@ proc httpTest::Puts {txt} { # A special-purpose logger used for running tests. # - Processes Log calls that have "^" in their arguments, and records them in # variable ::httpTest::testResults. -# - Also writes them to stderr (using Puts) if ($testOptions(-verbose) > 0). +# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0). # - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1). proc http::Log {args} { @@ -78,10 +78,10 @@ proc httpTest::LogRecord {txt} { set pos [string first ^ $txt] set len [string length $txt] if {$pos > $len - 3} { - puts stderr "Logging Error: $txt" - puts stderr "Fix this call to Log in http-*.tm so it has ^ then\ + puts stdout "Logging Error: $txt" + puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ a letter then a numeral." - flush stderr + flush stdout } elseif {$pos == -1} { # Called by mistake. } else { diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index 4046c7a..a8ef9c8 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -389,7 +389,7 @@ proc httpTestScript::Requester {uriCode keepAlive validate query args} { -command ::httpTestScript::WhenFinished } token]} { set msg $token - catch {puts stderr "Error: $msg"} + catch {puts stdout "Error: $msg"} return } else { # Request will begin. -- cgit v0.12 From 227db01958097c4aac9a9b57569db68002ab1187 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 21 Apr 2018 14:22:35 +0000 Subject: Restore production test settings: set tests/httpPipeline.test to non-verbose, and comment out most Log calls in library/http/http.tcl --- library/http/http.tcl | 128 ++++++++++++++++++++++++------------------------ tests/httpPipeline.test | 2 +- 2 files changed, 65 insertions(+), 65 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 4bde573..d16a8d9 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -358,7 +358,7 @@ proc http::KeepSocket {token} { upvar 0 $token3 state3 set tk2 [namespace tail $token3] - Log #Log pipelined, GRANT read access to $token3 in KeepSocket + #Log pipelined, GRANT read access to $token3 in KeepSocket set socketRdState($connId) $token3 ReceiveResponse $token3 @@ -397,13 +397,13 @@ proc http::KeepSocket {token} { # give that request read and write access. variable $token3 set conn [set ${token3}(tmpConnArgs)] - Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { $state(-pipeline) @@ -442,13 +442,13 @@ proc http::KeepSocket {token} { # case with a queued request. variable $token3 set conn [set ${token3}(tmpConnArgs)] - Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { (!$state(-pipeline)) @@ -464,13 +464,13 @@ proc http::KeepSocket {token} { set token3 [lindex $socketWrQueue($connId) 0] variable $token3 set conn [set ${token3}(tmpConnArgs)] - Log #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket + #Log nonpipeline, GRANT r/w access to $token3 in KeepSocket set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - Log #Log ---- $state(sock) << conn to $token3 for HTTP request (d) + #Log ---- $state(sock) << conn to $token3 for HTTP request (d) } elseif {(!$state(-pipeline))} { set socketWrState($connId) Wready @@ -710,7 +710,7 @@ proc http::geturl {url args} { set http(uid) 0 } set token [namespace current]::[incr http(uid)] - Log ##Log Starting http::geturl - token $token + ##Log Starting http::geturl - token $token variable $token upvar 0 $token state set tk [namespace tail $token] @@ -1098,8 +1098,8 @@ proc http::geturl {url args} { lappend sockopts -myaddr $state(-myaddr) } set pre [clock milliseconds] - Log ##Log pre socket opened, - token $token - Log ##Log [concat $defcmd $sockopts $targetAddr] - token $token + ##Log pre socket opened, - token $token + ##Log [concat $defcmd $sockopts $targetAddr] - token $token if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} { # Something went wrong while trying to establish the connection. # Clean up after events and such, but DON'T call the command @@ -1113,15 +1113,15 @@ proc http::geturl {url args} { return -options $errdict $sock } else { # Initialisation of a new socket. - Log ##Log post socket opened, - token $token - Log ##Log socket opened, now fconfigure - token $token + ##Log post socket opened, - token $token + ##Log socket opened, now fconfigure - token $token set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { Log socket delay $delay - token $token } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) - Log ##Log socket opened, DONE fconfigure - token $token + ##Log socket opened, DONE fconfigure - token $token } } # Command [socket] is called with -async, but takes 5s to 5.1s to return, @@ -1152,7 +1152,7 @@ proc http::geturl {url args} { } if {$state(-pipeline)} { - Log #Log new, init for pipelined, GRANT write access to $token in geturl + #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 @@ -1161,7 +1161,7 @@ proc http::geturl {url args} { # 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 #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } @@ -1206,13 +1206,13 @@ proc http::geturl {url args} { # subsequent calls on this socket will come here because the socket # will close after the current read, and its # socketClosing($connId) is 1. - Log ##Log "HTTP request for token $token is queued" + ##Log "HTTP request for token $token is queued" } elseif { $reusing && $state(-pipeline) && ($socketWrState($state(socketinfo)) ne "Wready") } { - Log ##Log "HTTP request for token $token is queued for pipelined use" + ##Log "HTTP request for token $token is queued for pipelined use" lappend socketWrQueue($state(socketinfo)) $token } elseif { $reusing @@ -1220,7 +1220,7 @@ proc http::geturl {url args} { && ($socketWrState($state(socketinfo)) ne "Wready") } { # A write is queued or in progress. Lappend to the write queue. - Log ##Log "HTTP request for token $token is queued for nonpipeline use" + ##Log "HTTP request for token $token is queued for nonpipeline use" lappend socketWrQueue($state(socketinfo)) $token } elseif { $reusing @@ -1231,20 +1231,20 @@ proc http::geturl {url args} { # A read is queued or in progress, but not a write. Cannot start the # nonpipeline transaction, but must set socketWrState to prevent a # pipelined request jumping the queue. - Log ##Log "HTTP request for token $token is queued for nonpipeline use" - Log #Log re-use nonpipeline, GRANT delayed write access to $token in geturl + ##Log "HTTP request for token $token is queued for nonpipeline use" + #Log re-use nonpipeline, GRANT delayed write access to $token in geturl set socketWrState($state(socketinfo)) peNding lappend socketWrQueue($state(socketinfo)) $token } else { if {$reusing && $state(-pipeline)} { - Log #Log re-use pipelined, GRANT write access to $token in geturl + #Log re-use pipelined, GRANT write access to $token in geturl set socketWrState($state(socketinfo)) $token } elseif {$reusing} { # Cf tests above - both are ready. - Log #Log re-use nonpipeline, GRANT r/w access to $token in geturl + #Log re-use nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token @@ -1254,7 +1254,7 @@ proc http::geturl {url args} { # All (!$reusing) cases come here, and also some $reusing cases if the # connection is ready. - Log #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) # Connect does its own fconfigure. fileevent $sock writable \ [list http::Connect $token $proto $phost $srvurl] @@ -1281,7 +1281,7 @@ proc http::geturl {url args} { return -code error $err } } - Log ##Log Leaving http::geturl - token $token + ##Log Leaving http::geturl - token $token return $token } @@ -1621,7 +1621,7 @@ proc http::DoneRequest {token} { && [info exists socketRdState($state(socketinfo))] && ($socketRdState($state(socketinfo)) eq "Rready") } { - Log #Log pipelined, GRANT read access to $token in Connected + #Log pipelined, GRANT read access to $token in Connected set socketRdState($state(socketinfo)) $token } @@ -1631,7 +1631,7 @@ proc http::DoneRequest {token} { && ($socketRdState($state(socketinfo)) ne $token) } { # Do not read from the socket until it is ready. - Log ##Log "HTTP response for token $token is queued for pipelined use" + ##Log "HTTP response for token $token is queued for pipelined use" # If $socketClosing(*), then the caller will be a pipelined write and # execution will come here. # This token has already been recorded as "in flight" for writing. @@ -1657,7 +1657,7 @@ proc http::ReceiveResponse {token} { set tk [namespace tail $token] set sock $state(sock) - Log #Log ---- $state(socketinfo) >> conn to $token for HTTP response + #Log ---- $state(socketinfo) >> conn to $token for HTTP response lassign [fconfigure $sock -translation] trRead trWrite fconfigure $sock -translation [list auto $trWrite] \ -buffersize $state(-blocksize) @@ -1718,13 +1718,13 @@ proc http::NextPipelinedWrite {token} { ) } { # - The usual case for a pipelined connection, ready for a new request. - Log #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite + #Log pipelined, GRANT write access to $token2 in NextPipelinedWrite set conn [set ${token2}(tmpConnArgs)] set socketWrState($connId) $token2 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token2 {*}$conn] - Log #Log ---- $connId << conn to $token2 for HTTP request (b) + #Log ---- $connId << conn to $token2 for HTTP request (b) # In the tests below, the next request will be nonpipeline. } elseif { $state(-pipeline) @@ -1747,13 +1747,13 @@ proc http::NextPipelinedWrite {token} { variable $token3 upvar 0 $token3 state3 set conn [set ${token3}(tmpConnArgs)] - Log #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite + #Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite set socketRdState($connId) $token3 set socketWrState($connId) $token3 set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end] # Connect does its own fconfigure. fileevent $state(sock) writable [list http::Connect $token3 {*}$conn] - Log #Log ---- $state(sock) << conn to $token3 for HTTP request (c) + #Log ---- $state(sock) << conn to $token3 for HTTP request (c) } elseif { $state(-pipeline) && [info exists socketWrState($connId)] @@ -1775,7 +1775,7 @@ proc http::NextPipelinedWrite {token} { # of the connection to $token2 will be done elsewhere - by command # http::KeepSocket when $socketRdState($connId) is set to "Rready". - Log #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. + #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. set socketWrState($connId) peNding } else { @@ -1804,7 +1804,7 @@ proc http::NextPipelinedWrite {token} { proc http::CancelReadPipeline {name1 connId op} { variable socketRdQueue - Log ##Log CancelReadPipeline $name1 $connId $op + ##Log CancelReadPipeline $name1 $connId $op if {[info exists socketRdQueue($connId)]} { set msg {the connection was closed by CancelReadPipeline} foreach token $socketRdQueue($connId) { @@ -1838,7 +1838,7 @@ proc http::CancelReadPipeline {name1 connId op} { proc http::CancelWritePipeline {name1 connId op} { variable socketWrQueue - Log ##Log CancelWritePipeline $name1 $connId $op + ##Log CancelWritePipeline $name1 $connId $op if {[info exists socketWrQueue($connId)]} { set msg {the connection was closed by CancelWritePipeline} foreach token $socketWrQueue($connId) { @@ -2124,7 +2124,7 @@ proc http::ReplayCore {newQueue} { return } - Log ##Log running ReplayCore for {*}$newQueue + ##Log running ReplayCore for {*}$newQueue set newToken [lindex $newQueue 0] set newQueue [lrange $newQueue 1 end] @@ -2156,8 +2156,8 @@ proc http::ReplayCore {newQueue} { } set pre [clock milliseconds] - Log ##Log pre socket opened, - token $token - Log ##Log $tmpOpenCmd - token $token + ##Log pre socket opened, - token $token + ##Log $tmpOpenCmd - token $token # 4. Open a socket. if {[catch {eval $tmpOpenCmd} sock]} { # Something went wrong while trying to establish the connection. @@ -2166,7 +2166,7 @@ proc http::ReplayCore {newQueue} { Finish $token $sock return } - Log ##Log post socket opened, - token $token + ##Log post socket opened, - token $token set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { Log socket delay $delay - token $token @@ -2194,11 +2194,11 @@ proc http::ReplayCore {newQueue} { } if {$state(-pipeline)} { - Log #Log new, init for pipelined, GRANT write acc to $token ReplayCore + #Log new, init for pipelined, GRANT write acc to $token ReplayCore set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } else { - Log #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore + #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token } @@ -2209,7 +2209,7 @@ proc http::ReplayCore {newQueue} { set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} } - Log ##Log pre newQueue ReInit, - token $token + ##Log pre newQueue ReInit, - token $token # 6. Configure sockets in the queue. foreach tok $newQueue { if {[ReInit $tok]} { @@ -2228,13 +2228,13 @@ proc http::ReplayCore {newQueue} { [expr {$state(-keepalive)?"keepalive":""}] # Initialisation of a new socket. - Log ##Log socket opened, now fconfigure - token $token + ##Log socket opened, now fconfigure - token $token fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) - Log ##Log socket opened, DONE fconfigure - token $token + ##Log socket opened, DONE fconfigure - token $token # Connect does its own fconfigure. fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] - Log #Log ---- $sock << conn to $token for HTTP request (e) + #Log ---- $sock << conn to $token for HTTP request (e) return } @@ -2493,7 +2493,7 @@ proc http::Event {sock token} { set tk [namespace tail $token] while 1 { yield - Log ##Log Event call - token $token + ##Log Event call - token $token if {![info exists state]} { Log "Event $sock with invalid token '$token' - remote close?" @@ -2508,7 +2508,7 @@ proc http::Event {sock token} { return } if {$state(state) eq "connecting"} { - Log ##Log - connecting - token $token + ##Log - connecting - token $token if { $state(reusing) && $state(-pipeline) && ($state(-timeout) > 0) @@ -2540,7 +2540,7 @@ proc http::Event {sock token} { return } } elseif {$nsl >= 0} { - Log ##Log - connecting 1 - token $token + ##Log - connecting 1 - token $token set state(state) "header" } elseif { [eof $sock] && [info exists state(reusing)] @@ -2560,18 +2560,18 @@ proc http::Event {sock token} { # If any other requests are in flight or pipelined/queued, they # will be discarded. } else { - Log ##Log - connecting 2 - token $token + ##Log - connecting 2 - token $token # nsl is -1 so either fblocked (OK) or (eof and not reusing). # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { - Log ##Log header failed - token $token + ##Log header failed - token $token Log ^X$tk end of response (error) - token $token Finish $token $nhl return } elseif {$nhl == 0} { - Log ##Log header done - token $token + ##Log header done - token $token Log ^E$tk end of response headers - token $token # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 @@ -2612,7 +2612,7 @@ proc http::Event {sock token} { } { # The server warns that it will close the socket after this # response. - Log ##Log WARNING - socket will close after response for $token + ##Log WARNING - socket will close after response for $token # Prepare data for a call to ReplayIfClose. if { ($socketRdQueue($state(socketinfo)) ne {}) || ($socketWrQueue($state(socketinfo)) ne {}) @@ -2624,7 +2624,7 @@ proc http::Event {sock token} { set InFlightW Wready } else { set msg "token ${InFlightW} is InFlightW" - Log ##Log $msg - token $token + ##Log $msg - token $token } set socketPlayCmd($state(socketinfo)) \ @@ -2717,7 +2717,7 @@ proc http::Event {sock token} { } } elseif {$nhl > 0} { # Process header lines. - Log ##Log header - token $token - $line + ##Log header - token $token - $line if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { switch -- [string tolower $key] { content-type { @@ -2753,11 +2753,11 @@ proc http::Event {sock token} { } } else { # Now reading body - Log ##Log body - token $token + ##Log body - token $token if {[catch { if {[info exists state(-handler)]} { set n [eval $state(-handler) [list $sock $token]] - Log ##Log handler $n - token $token + ##Log handler $n - token $token # N.B. the protocol has been set to 1.0 because the -handler # logic is not expected to handle chunked encoding. # FIXME Allow -handler with 1.1 on dechunked stacked chan. @@ -2819,20 +2819,20 @@ proc http::Event {sock token} { } elseif { [info exists state(transfer)] && ($state(transfer) eq "chunked") } { - Log ##Log chunked - token $token + ##Log chunked - token $token set size 0 set hexLenChunk [getTextLine $sock] #set ntl [string length $hexLenChunk] if {[string trim $hexLenChunk] ne ""} { scan $hexLenChunk %x size if {$size != 0} { - Log ##Log chunk-measure $size - token $token + ##Log chunk-measure $size - token $token set chunk [BlockingRead $sock $size] set n [string length $chunk] if {$n >= 0} { append state(body) $chunk incr state(log_size) [string length $chunk] - Log ##Log chunk $n cumul $state(log_size) -\ + ##Log chunk $n cumul $state(log_size) -\ token $token } if {$size != [string length $chunk]} { @@ -2856,7 +2856,7 @@ proc http::Event {sock token} { } } else { # Line expected to hold chunk length is empty, or eof. - Log ##Log bad-chunk-measure - token $token + ##Log bad-chunk-measure - token $token set n 0 set state(connection) close Log ^X$tk end of response (chunk error) - token $token @@ -2864,7 +2864,7 @@ proc http::Event {sock token} { fetch terminated} } } else { - Log ##Log unchunked - token $token + ##Log unchunked - token $token if {$state(totalsize) == 0} { # We know the transfer is complete only when the server # closes the connection. @@ -2885,13 +2885,13 @@ proc http::Event {sock token} { } set c $state(currentsize) set t $state(totalsize) - Log ##Log non-chunk currentsize $c of totalsize $t -\ + ##Log non-chunk currentsize $c of totalsize $t -\ token $token set block [read $sock $reqSize] set n [string length $block] if {$n >= 0} { append state(body) $block - Log ##Log non-chunk [string length $state(body)] -\ + ##Log non-chunk [string length $state(body)] -\ token $token } } @@ -2902,7 +2902,7 @@ proc http::Event {sock token} { incr state(currentsize) $n set c $state(currentsize) set t $state(totalsize) - Log ##Log another $n currentsize $c totalsize $t -\ + ##Log another $n currentsize $c totalsize $t -\ token $token } # If Content-Length - check for end of data. @@ -2931,7 +2931,7 @@ proc http::Event {sock token} { # catch as an Eot above may have closed the socket already # $state(state) may be connecting, header, body, or complete if {![set cc [catch {eof $sock} eof]] && $eof} { - Log ##Log eof - token $token + ##Log eof - token $token if {[info exists $token]} { set state(connection) close if {$state(state) eq "complete"} { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 4823d19..5eb02d3 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -648,7 +648,7 @@ proc RunTest {header footer delay te} { # If still obscure, uncomment #Log and ##Log lines in the http package. # ------------------------------------------------------------------------------ -setHttpTestOptions -verbose 2 +setHttpTestOptions -verbose 0 # ------------------------------------------------------------------------------ # (4) Define the base URLs used for testing. Each must have a query string. -- cgit v0.12 -- cgit v0.12 From c2fceada6c1e45c299dacdbe6111f97c41b68c98 Mon Sep 17 00:00:00 2001 From: fbonnet Date: Sun, 13 May 2018 22:15:36 +0000 Subject: Initial implementation of TIP #508: [array default] --- generic/tclExecute.c | 5 +- generic/tclInt.h | 6 ++ generic/tclVar.c | 288 ++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 278 insertions(+), 21 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fda50b2..7d7384f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4070,10 +4070,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); #ifdef TCL_COMPILE_DEBUG TRACE_APPEND(("done\n")); } else { diff --git a/generic/tclInt.h b/generic/tclInt.h index 8f5d8ba..c0630ef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4100,6 +4100,12 @@ MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, Tcl_Obj **errorObjPtr); /* + * TIP #508: [array default] + */ + +MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); + +/* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index d5e0fa1..78188d2 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -198,6 +198,17 @@ static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Tcl_Obj *part2Ptr, int flags, int index); /* + * TIP #508: [array default] + */ + +static int ArrayDefaultCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void DeleteArrayVar(Var *arrayPtr); +static Tcl_Obj * GetArrayDefault(Var *arrayPtr); +static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); + +/* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -1015,8 +1026,6 @@ TclLookupArrayElement( { int isNew; Var *varPtr; - TclVarHashTable *tablePtr; - Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array @@ -1049,16 +1058,7 @@ TclLookupArrayElement( return NULL; } - TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(TclVarHashTable)); - arrayPtr->value.tablePtr = tablePtr; - - if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { - nsPtr = TclGetVarNsPtr(arrayPtr); - } else { - nsPtr = NULL; - } - TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); + TclInitArrayVar(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, @@ -1408,6 +1408,13 @@ TclPtrGetVarIdx( return varPtr->value.objPtr; } + /* + * Return the array default value if any. + */ + if (arrayPtr && TclIsVarArray(arrayPtr) && GetArrayDefault(arrayPtr)) { + return GetArrayDefault(arrayPtr); + } + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { @@ -4074,9 +4081,7 @@ ArraySetCmd( return TCL_ERROR; } } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); return TCL_OK; } @@ -4356,6 +4361,7 @@ TclInitArrayCmd( { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, @@ -5546,8 +5552,7 @@ DeleteArray( TclClearVarNamespaceVar(elPtr); } - VarHashDeleteTable(varPtr->value.tablePtr); - ckfree(varPtr->value.tablePtr); + DeleteArrayVar(varPtr); } /* @@ -6436,6 +6441,255 @@ CompareVarKeys( } /* + * TIP #508: [array default] + */ + +/* + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/*---------------------------------------------------------------------- + * + * ArrayDefaultCmd -- + * + * This function implements the 'array default' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayDefaultCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const options[] = { + "get", "set", "exists", "unset", NULL + }; + enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + Tcl_Obj *arrayNameObj, *defaultValueObj; + Var *varPtr, *arrayPtr; + int isArray, option; + + /* + * Parse arguments. + */ + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &option) != TCL_OK) { + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { + return TCL_ERROR; + } + + switch (option) { + case OPT_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (!varPtr || !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + defaultValueObj = GetArrayDefault(varPtr); + if (!defaultValueObj) { + /* Array default must exist. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array has no default value", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, defaultValueObj); + return TCL_OK; + + case OPT_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); + return TCL_ERROR; + } + + /* + * Attempt to create array if needed. + */ + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + /* + * Not a valid array name. + */ + + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * Not an array. + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + return TCL_ERROR; + } + + if (!TclIsVarArray(varPtr)) { + TclInitArrayVar(varPtr); + } + defaultValueObj = objv[3]; + SetArrayDefault(varPtr, defaultValueObj); + return TCL_OK; + + case OPT_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (varPtr && !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + if (!varPtr) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else { + defaultValueObj = GetArrayDefault(varPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); + } + return TCL_OK; + + case OPT_UNSET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (varPtr && !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + if (varPtr) { + SetArrayDefault(varPtr, NULL); + } + return TCL_OK; + } + + /* Unreached */ + return TCL_ERROR; +} + +/* + * Initialize array variable. + */ + +void +TclInitArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr; + + TclSetVarArray(arrayPtr); + + tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + // Regular TclVarHashTable initialization. + arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; + TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + + // Default value initialization. + tablePtr->defaultObj = NULL; +} + +/* + * Cleanup array variable. + */ + +static void +DeleteArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + + // Default value cleanup. + SetArrayDefault(arrayPtr, NULL); + + // Regular TclVarHashTable cleanup. + VarHashDeleteTable(arrayPtr->value.tablePtr); + + ckfree(tablePtr); +} + +/* + * Get array default value if any. + */ + +static Tcl_Obj * +GetArrayDefault( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + return tablePtr->defaultObj; +} + +/* + * Set/replace/unset array default value. + */ + +static void +SetArrayDefault( + Var *arrayPtr, + Tcl_Obj *defaultObj) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + + /* + * Increment/decrement refcount twice to ensure that the object is shared, + * so that it doesn't get modified accidentally by the folling code: + * + * array default set v 1 + * lappend v(a) 2; # returns a new object {1 2} + * set v(b); # returns the original default object "1" + */ + if (tablePtr->defaultObj) { + Tcl_DecrRefCount(tablePtr->defaultObj); + Tcl_DecrRefCount(tablePtr->defaultObj); + } + tablePtr->defaultObj = defaultObj; + if (tablePtr->defaultObj) { + Tcl_IncrRefCount(tablePtr->defaultObj); + Tcl_IncrRefCount(tablePtr->defaultObj); + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From 754bb107b4100f394d445d589dddc94e59dd2d04 Mon Sep 17 00:00:00 2001 From: kjnash Date: Fri, 1 Jun 2018 18:34:07 +0000 Subject: Bugfix - always cleanup persistent socket. --- library/http/http.tcl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index d16a8d9..c177374 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -264,8 +264,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { || ([info exists state(-keepalive)] && !$state(-keepalive)) || ([info exists state(connection)] && ($state(connection) eq "close")) } { - CloseSocket $state(sock) $token set closeQueue 1 + set connId $state(socketinfo) + set sock $state(sock) + CloseSocket $state(sock) $token } elseif { ([info exists state(-keepalive)] && $state(-keepalive)) && ([info exists state(connection)] && ($state(connection) ne "close")) @@ -286,11 +288,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } if { $closeQueue - && [info exists state(socketinfo)] - && [info exists socketMapping($state(socketinfo))] - && ($socketMapping($state(socketinfo)) eq $state(sock)) + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $sock) } { - http::CloseQueuedQueries $state(socketinfo) $token + http::CloseQueuedQueries $connId $token } return -- cgit v0.12 From 833b02bc83665b70d5af4696ad54b3d83c51d11b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Sep 2018 09:53:17 +0000 Subject: TIP #515 implementation: Level Value Reform --- doc/uplevel.n | 4 +-- generic/tclProc.c | 90 +++++++++++++++++++----------------------------------- tests/uplevel.test | 26 ++++++++-------- 3 files changed, 46 insertions(+), 74 deletions(-) diff --git a/doc/uplevel.n b/doc/uplevel.n index 4decc6d..cda1652 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -24,9 +24,9 @@ the result of that evaluation. If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by -a number then the number gives an absolute level number. If \fIlevel\fR +a integer then the level gives an absolute level. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be -defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. +defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. diff --git a/generic/tclProc.c b/generic/tclProc.c index 212b680..b9d309f 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -688,51 +688,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* @@ -770,6 +734,7 @@ TclObjGetFrame( register Interp *iPtr = (Interp *) interp; int curLevel, level, result; const char *name = NULL; + Tcl_WideInt w; /* * Parse object to figure out which level number to go to. @@ -785,25 +750,33 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { - level = curLevel - level; - result = 1; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { + result = -1; + } else { + level = curLevel - level; + result = 1; + } } else if (objPtr->typePtr == &levelReferenceType) { level = (int) objPtr->internalRep.wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.wideValue = level; - result = 1; + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { + if (level < 0 || (level > 0 && name[1] == '-')) { + result = -1; + } else { + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.wideValue = level; + result = 1; + } } else { result = -1; } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. @@ -814,7 +787,6 @@ TclObjGetFrame( if (result == 0) { level = curLevel - 1; - name = "1"; } if (result != -1) { if (level >= 0) { @@ -827,11 +799,11 @@ TclObjGetFrame( } } } - if (name == NULL) { - name = TclGetString(objPtr); - } } + if (name == NULL) { + name = TclGetString(objPtr); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; diff --git a/tests/uplevel.test b/tests/uplevel.test index 737c571..be2268a 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -137,27 +137,27 @@ test uplevel-4.15 {level parsing} { test uplevel-4.16 {level parsing} { apply {{} {uplevel #[expr 1] {}}} } {} -test uplevel-4.17 {level parsing} { +test uplevel-4.17 {level parsing} -returnCodes error -body { apply {{} {uplevel -0xffffffff {}}} -} {} -test uplevel-4.18 {level parsing} { +} -result {bad level "-0xffffffff"} +test uplevel-4.18 {level parsing} -returnCodes error -body { apply {{} {uplevel #-0xffffffff {}}} -} {} -test uplevel-4.19 {level parsing} { +} -result {bad level "#-0xffffffff"} +test uplevel-4.19 {level parsing} -returnCodes error -body { apply {{} {uplevel [expr -0xffffffff] {}}} -} {} -test uplevel-4.20 {level parsing} { +} -result {bad level "-4294967295"} +test uplevel-4.20 {level parsing} -returnCodes error -body { apply {{} {uplevel #[expr -0xffffffff] {}}} -} {} +} -result {bad level "#-4294967295"} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} @@ -175,13 +175,13 @@ test uplevel-4.28 {level parsing} -body { } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -193,7 +193,7 @@ test uplevel-4.34 {level parsing} -body { } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} -- cgit v0.12 From 0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Sep 2018 12:52:06 +0000 Subject: Implementation of TIP 516 --- generic/tclOODefineCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++------ generic/tclOOScript.h | 28 +++++++++++++-- generic/tclOOScript.tcl | 39 +++++++++++++++++++-- tests/oo.test | 16 ++++----- 4 files changed, 144 insertions(+), 25 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 3c27236..e4a30bb 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,14 +37,17 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; + const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} + setter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + resolver, NULL, NULL}} /* * Forward declarations. @@ -109,20 +112,23 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int ResolveClasses(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClasses), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* @@ -2063,6 +2069,7 @@ TclOODefineSlots( const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) @@ -2072,9 +2079,10 @@ TclOODefineSlots( } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); + Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; @@ -2083,9 +2091,14 @@ TclOODefineSlots( &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); + if (slotInfoPtr->resolverType.callProc) { + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + &slotInfoPtr->resolverType, NULL); + } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); + Tcl_DecrRefCount(resolveName); return TCL_OK; } @@ -2814,6 +2827,57 @@ ObjVarsSet( return TCL_OK; } + +static int +ResolveClasses( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int cmdc, i, mustReset = 0; + Tcl_Obj **cmdv, **cmdv2; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "list"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, + &cmdv) != TCL_OK) { + return TCL_ERROR; + } + + cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); + + /* + * Resolve each o + */ + + for (i=0 ; ithisPtr); + } + } + + if (mustReset) { + Tcl_ResetResult(interp); + } + Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); + TclStackFree(interp, cmdv2); + return TCL_OK; +} + /* * Local Variables: * mode: c diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index e63bd86..5627bf8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -147,12 +147,34 @@ static const char *tclOOSetupScript = "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod -set args {tailcall my Set $args}\n" +"\t\tmethod Resolve list {\n" +"\t\t\treturn $list\n" +"\t\t}\n" +"\t\tmethod -set args {\n" +"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $args]]\n" +"\t\t\ttailcall my Set $args\n" +"\t\t}\n" "\t\tmethod -append args {\n" -"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" "\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tmethod -prepend args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" +"\t\t}\n" +"\t\tmethod -remove args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [lmap val $current {\n" +"\t\t\t\tif {$val in $args} continue else {set val}\n" +"\t\t\t}]\n" +"\t\t}\n" "\t\tforward --default-operation my -append\n" "\t\tmethod unknown {args} {\n" "\t\t\tset def --default-operation\n" @@ -163,7 +185,7 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\n" -"\t\texport -set -append -clear\n" +"\t\texport -set -append -clear -prepend -remove\n" "\t\tunexport unknown destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index d3706ce..30af82a 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -276,6 +276,20 @@ # ------------------------------------------------------------------ # + # Slot Resolve -- + # + # Helper that lets a slot convert a list of arguments of a + # particular type to their canonical forms. Defaults to doing + # nothing (suitable for simple strings). + # + # ------------------------------------------------------------------ + + method Resolve list { + return $list + } + + # ------------------------------------------------------------------ + # # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out @@ -283,12 +297,31 @@ # # ------------------------------------------------------------------ - method -set args {tailcall my Set $args} + method -set args { + set args [uplevel 1 [list [namespace which my] Resolve $args]] + tailcall my Set $args + } method -append args { - set current [uplevel 1 [list [namespace which my] Get]] + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [lmap val $current { + if {$val in $args} continue else {set val} + }] + } # Default handling forward --default-operation my -append @@ -303,7 +336,7 @@ } # Set up what is exported and what isn't - export -set -append -clear + export -set -append -clear -prepend -remove unexport unknown destroy } diff --git a/tests/oo.test b/tests/oo.test index a303309..2dc9e2a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3920,7 +3920,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -set, contents or ops} + {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -3950,25 +3950,25 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { -- cgit v0.12 From 4f178616784e701a7b93586556ffbf292dd173aa Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2018 08:33:11 +0000 Subject: Tests and docs --- doc/define.n | 64 +++++++++++++++++++++++++++++++++++++++++++++++---- tests/oo.test | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 128 insertions(+), 10 deletions(-) diff --git a/doc/define.n b/doc/define.n index 6353d00..1030096 100644 --- a/doc/define.n +++ b/doc/define.n @@ -426,7 +426,7 @@ Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of -the slot. The class defines three operations (as methods) that may be done on +the slot. The class defines five operations (as methods) that may be done on the slot: .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? @@ -437,6 +437,16 @@ This appends the given \fImember\fR elements to the slot definition. . This sets the slot definition to the empty list. .TP +\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? +.VS TIP516 +This prepends the given \fImember\fR elements to the slot definition. +.VE TIP516 +.TP +\fIslot\fR \fB\-remove\fR ?\fImember ...\fR? +.VS TIP516 +This removes the given \fImember\fR elements from the slot definition. +.VE TIP516 +.TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . This replaces the slot definition with the given \fImember\fR elements. @@ -454,15 +464,53 @@ and these methods which provide the implementation interface: .TP \fIslot\fR \fBGet\fR . -Returns a list that is the current contents of the slot. This method must +Returns a list that is the current contents of the slot, but does not modify +the slot. This method must always be called from a stack frame created by a +call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR +return an error unless it is called from outside a definition context or with +the wrong number of arguments. +.RS +.PP +.VS TIP516 +The elements of the list should be fully resolved, if that is a meaningful +concept to the slot. +.VE TIP516 +.RE +.TP +\fIslot\fR \fBResolve\fR \fIelementList\fR +.VS TIP516 +Returns a list that is the elements of \fIelementList\fR with a resolution +operation applied to each of them, but does not modify the slot. For slots of +simple strings, this is an operation that does nothing. For slots of classes, +this maps each class name to its fully qualified class name. This method must always be called from a stack frame created by a call to \fBoo::define\fR or -\fBoo::objdefine\fR. +\fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it +is called from outside a definition context or with the wrong number of +arguments. +.RS +.PP +Implementations \fIshould not\fR reorder or filter elements in this operation; +uniqueness and ordering constraints should be enforced in the \fBSet\fR +method. This is because this method is not normally presented with the full +contents of the slot (except via the \fB\-set\fR slot operation). +.RE +.VE TIP516 .TP \fIslot\fR \fBSet \fIelementList\fR . Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by -a call to \fBoo::define\fR or \fBoo::objdefine\fR. +a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an +error if it rejects the change to the slot contents (e.g., because of invalid +values) as well as if it is called from outside a definition context or with +the wrong number of arguments. +.RS +.PP +This method \fImay\fR reorder and filter the elements if this is necessary in +order to satisfy the underlying constraints of the slot. (For example, slots +of classes enforce a uniqueness constraint that places each element in the +earliest location in the slot that it can.) +.RE .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have @@ -470,6 +518,14 @@ an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism be restricted to defining new operations whose names start with a hyphen. +.PP +.VS TIP516 +Most slot operations will initially \fBResolve\fR their argument list, combine +it with the results of the \fBGet\fR method, and then \fBSet\fR the result. +Some operations omit one or both of the first two steps; omitting the third +would result in an idempotent read-only operation (but the standard mechanism +for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). +.VE TIP516 .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as diff --git a/tests/oo.test b/tests/oo.test index 2dc9e2a..1093f8d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } - # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. - testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -3838,6 +3836,11 @@ proc SampleSlotSetup script { lappend ops [info level] Set $lst return } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } } } append script0 \n$script @@ -3872,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3880,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3888,7 +3891,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -prepend g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -remove c a] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] @@ -3911,7 +3930,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} -}] -result {{} unknown {1 Set destroy 1 Set unknown}} +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { @@ -3969,6 +3988,49 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -prepend -remove -set} {Get Set}} +test oo-34.10 {TIP 516: slots - resolution} -setup { + oo::class create parent + set result {} + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + namespace eval 516test { + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + } +} -body { + # Must find the right classes when making the mixin + namespace eval 516test { + oo::define 516a { + mixin 516b 516c + } + } + lappend result [info class mixin 516test::516a] + # Must not remove class with just simple name match + oo::define 516test::516a { + mixin -remove 516b + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match + oo::define 516test::516a { + mixin -remove 516test::516c + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match even after renaming, but only + # with the renamed name; it is a slot of classes, not strings! + rename 516test::516b 516test::516d + oo::define 516test::516a { + mixin -remove 516test::516b + } + lappend result [info class mixin 516test::516a] + oo::define 516test::516a { + mixin -remove 516test::516d + } + lappend result [info class mixin 516test::516a] +} -cleanup { + parent destroy +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { -- cgit v0.12 From 90e3bdc291f94c2e3ff1c4e5b0edb6e203966147 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Sep 2018 07:44:04 +0000 Subject: Simplify the slot resolution protocol --- doc/define.n | 25 +++++++++-------- generic/tclOODefineCmds.c | 68 ++++++++++++++++++++++++----------------------- generic/tclOOScript.h | 9 ++++--- generic/tclOOScript.tcl | 9 ++++--- tests/oo.test | 10 +++---- 5 files changed, 62 insertions(+), 59 deletions(-) diff --git a/doc/define.n b/doc/define.n index 1030096..883d5fa 100644 --- a/doc/define.n +++ b/doc/define.n @@ -477,22 +477,21 @@ concept to the slot. .VE TIP516 .RE .TP -\fIslot\fR \fBResolve\fR \fIelementList\fR +\fIslot\fR \fBResolve\fR \fIslotElement\fR .VS TIP516 -Returns a list that is the elements of \fIelementList\fR with a resolution -operation applied to each of them, but does not modify the slot. For slots of -simple strings, this is an operation that does nothing. For slots of classes, -this maps each class name to its fully qualified class name. This method must -always be called from a stack frame created by a call to \fBoo::define\fR or -\fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it -is called from outside a definition context or with the wrong number of -arguments. +Returns \fIslotElement\fR with a resolution operation applied to it, but does +not modify the slot. For slots of simple strings, this is an operation that +does nothing, whereas for slots of classes, this maps a class name to its +fully-qualified class name. This method must always be called from a stack +frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This +method \fIshould not\fR return an error unless it is called from outside a +definition context or with the wrong number of arguments; unresolvable +arguments should be returned as is (as not all slot operations strictly +require that values are resolvable to work). .RS .PP -Implementations \fIshould not\fR reorder or filter elements in this operation; -uniqueness and ordering constraints should be enforced in the \fBSet\fR -method. This is because this method is not normally presented with the full -contents of the slot (except via the \fB\-set\fR slot operation). +Implementations \fIshould not\fR enforce uniqueness and ordering constraints +in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 .TP diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e4a30bb..b68cb0c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -112,7 +112,7 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int ResolveClasses(ClientData clientData, +static int ResolveClass(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -122,11 +122,11 @@ static int ResolveClasses(ClientData clientData, static const struct DeclaredSlot slots[] = { SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClasses), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; @@ -2827,54 +2827,56 @@ ObjVarsSet( return TCL_OK; } +/* + * ---------------------------------------------------------------------- + * + * ResolveClass -- + * + * Implementation of the "Resolve" support method for some slots (those + * that are slots around a list of classes). This resolves possible class + * names to their fully-qualified names if possible. + * + * ---------------------------------------------------------------------- + */ static int -ResolveClasses( +ResolveClass( ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { + int idx = Tcl_ObjectContextSkippedArgs(context); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int cmdc, i, mustReset = 0; - Tcl_Obj **cmdv, **cmdv2; + Class *clsPtr; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "list"); - return TCL_ERROR; - } else if (oPtr == NULL) { + /* + * Check if were called wrongly. The definition context isn't used... + * except that GetClassInOuterContext() assumes that it is there. + */ + + if (oPtr == NULL) { return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, - &cmdv) != TCL_OK) { + } else if (objc != idx + 1) { + Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); return TCL_ERROR; } - cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); - /* - * Resolve each o + * Resolve the class if possible. If not, remove any resolution error and + * return what we've got anyway as the failure might not be fatal overall. */ - for (i=0 ; ithisPtr); - } - } - - if (mustReset) { + clsPtr = GetClassInOuterContext(interp, objv[idx], + "USER SHOULD NOT SEE THIS MESSAGE"); + if (clsPtr == NULL) { Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, objv[idx]); + } else { + Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } - Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); - TclStackFree(interp, cmdv2); + return TCL_OK; } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 5627bf8..2213ce3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -151,25 +151,26 @@ static const char *tclOOSetupScript = "\t\t\treturn $list\n" "\t\t}\n" "\t\tmethod -set args {\n" -"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $args]]\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\ttailcall my Set $args\n" "\t\t}\n" "\t\tmethod -append args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" "\t\tmethod -clear {} {tailcall my Set {}}\n" "\t\tmethod -prepend args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$args {*}$current]\n" "\t\t}\n" "\t\tmethod -remove args {\n" "\t\t\tset my [namespace which my]\n" -"\t\t\tset args [uplevel 1 [list $my Resolve $args]]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [lmap val $current {\n" "\t\t\t\tif {$val in $args} continue else {set val}\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index 30af82a..a48eab5 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -298,25 +298,26 @@ # ------------------------------------------------------------------ method -set args { - set args [uplevel 1 [list [namespace which my] Resolve $args]] + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] tailcall my Set $args } method -append args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} method -prepend args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$args {*}$current] } method -remove args { set my [namespace which my] - set args [uplevel 1 [list $my Resolve $args]] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [lmap val $current { if {$val in $args} continue else {set val} diff --git a/tests/oo.test b/tests/oo.test index 1093f8d..033daf5 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3875,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3883,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3891,7 +3891,7 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3899,7 +3899,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}} +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3907,7 +3907,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -- cgit v0.12 From df89a7f2110fcd0e00738488b7c9e54f7357feb3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 10:09:23 +0000 Subject: Prevent possible build order problem, due to missing dde/registry dll's. Make sure that Tcl_WinTChar2Utf() never produces intermediate null-bytes. --- generic/tclStubInit.c | 17 +++++++++++++---- win/Makefile.in | 2 +- win/tclWin32Dll.c | 17 +++++++++++++---- 3 files changed, 27 insertions(+), 9 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 134b68f..cb33288 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -242,7 +242,7 @@ Tcl_WinUtfToTChar( while (p < wp + size - 1) { if (p[0] == 0xfffd && p[1] == 0xfffd) { memmove(p+1, p+2, sizeof(WCHAR) * (p - wp + size - 2)); - p[0] = 0; + p[0] = '\0'; ++p; --size; } ++p; @@ -258,7 +258,7 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { - char *p; + char *p, *r; int size; if (len > 0) { @@ -266,10 +266,19 @@ Tcl_WinTCharToUtf( } size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); Tcl_DStringInit(dsPtr); - Tcl_DStringSetLength(dsPtr, size+1); - p = (char *)Tcl_DStringValue(dsPtr); + Tcl_DStringSetLength(dsPtr, size+8); /* Add some spare, in case of NULL-bytes */ + r = p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); if (len == -1) --size; /* account for 0-byte at string end */ + while (r < p+size) { + if (!*r) { + /* Output contains '\0'-byte, but Tcl expect two-bytes: C0 80 */ + memmove(r+2, r+1, p-r+size-1); + memcpy(r++, "\xC0\x80", 2); + Tcl_DStringSetLength(dsPtr, ++size + 1); + } + ++r; + } Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; diff --git a/win/Makefile.in b/win/Makefile.in index b5095e7..3e117d1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -482,7 +482,7 @@ doc: tclzipfile: ${TCL_ZIP_FILE} -${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} +${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS} ${DDE_DLL_FILE} ${REG_DLL_FILE} rm -rf ${TCL_VFS_ROOT} mkdir -p ${TCL_VFS_PATH} $(COPY) -a $(TOP_DIR)/library/* ${TCL_VFS_PATH} diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 26da566..2216a66 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -488,7 +488,7 @@ Tcl_WinUtfToTChar( while (p < wp + size - 1) { if (p[0] == 0xfffd && p[1] == 0xfffd) { memmove(p+1, p+2, sizeof(TCHAR) * (p - wp + size - 2)); - p[0] = 0; + p[0] = '\0'; ++p; --size; } ++p; @@ -506,7 +506,7 @@ Tcl_WinTCharToUtf( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - char *p; + char *p, *r; int size; if (len > 0) { @@ -514,10 +514,19 @@ Tcl_WinTCharToUtf( } size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); Tcl_DStringInit(dsPtr); - Tcl_DStringSetLength(dsPtr, size+1); - p = (char *)Tcl_DStringValue(dsPtr); + Tcl_DStringSetLength(dsPtr, size+8); /* Add some spare, in case of NULL-bytes */ + r = p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); if (len == -1) --size; /* account for 0-byte at string end */ + while (r < p+size) { + if (!*r) { + /* Output contains '\0'-byte, but Tcl expect two-bytes: C0 80 */ + memmove(r+2, r+1, p-r+size-1); + memcpy(r++, "\xC0\x80", 2); + Tcl_DStringSetLength(dsPtr, ++size + 1); + } + ++r; + } Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -- cgit v0.12 From 63ef0e3d26d5ef38c104cb50b97e7cddb70dbba6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 10:20:28 +0000 Subject: Update http version number, and fix some related test-cases --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- tests/http.test | 6 +++--- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index c177374..643a119 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.13 +package provide http 2.9.0 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 3324af9..4f74635 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.8.13 [list tclPkgSetup $dir http 2.8.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http.test b/tests/http.test index 5a00cd5..242dceb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -86,7 +86,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] +} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -101,10 +101,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} +} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} +} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { diff --git a/unix/Makefile.in b/unix/Makefile.in index 060148f..a2621a3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -842,8 +842,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.13 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.13.tm; + @echo "Installing package http 2.9.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.9.0.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index f063da1..eee688b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.13 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.13.tm; + @echo "Installing package http 2.9.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.9.0.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From 25ac7e62ba116fcef8119b89b050bf4e09059af8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 12:05:14 +0000 Subject: forgot one location for http version number --- library/init.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/init.tcl b/library/init.tcl index 61f2c12..51339d0 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -805,7 +805,7 @@ set isafe [interp issafe] set isafe [interp issafe] set dir [file dirname [info script]] foreach {safe package version file} { - 0 http 2.8.13 {http http.tcl} + 0 http 2.9.0 {http http.tcl} 1 msgcat 1.7.0 {msgcat msgcat.tcl} 1 opt 0.4.7 {opt optparse.tcl} 0 platform 1.0.14 {platform platform.tcl} -- cgit v0.12 From 31b9d1f712fb47f0376a53db5d67d5c2c844d0ce Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 12:29:46 +0000 Subject: Fix a couple of test-cases, since http1.0 is no longer there --- tests/zipfs.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/zipfs.test b/tests/zipfs.test index 5f5b93c..1a5225c 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -61,7 +61,7 @@ test zipfs-0.3 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -dir . http*] } -cleanup { cd $pwd -} -result {./http ./http1.0} +} -result {./http} test zipfs-0.4 {zipfs basics: glob} -constraints zipfs -body { set pwd [pwd] @@ -69,23 +69,23 @@ test zipfs-0.4 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -dir [pwd] http*] } -cleanup { cd $pwd -} -result [list $tcl_library/http $tcl_library/http1.0] +} -result [list $tcl_library/http] test zipfs-0.5 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -dir $tcl_library http*] -} -result [list $tcl_library/http $tcl_library/http1.0] +} -result [list $tcl_library/http] test zipfs-0.6 {zipfs basics: glob} -constraints zipfs -body { lsort [glob $tcl_library/http*] -} -result [list $tcl_library/http $tcl_library/http1.0] +} -result [list $tcl_library/http] test zipfs-0.7 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -tails -dir $tcl_library http*] -} -result {http http1.0} +} -result {http} test zipfs-0.8 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -nocomplain -tails -types d -dir $tcl_library http*] -} -result {http http1.0} +} -result {http} test zipfs-0.9 {zipfs basics: glob} -constraints zipfs -body { lsort [glob -nocomplain -tails -types f -dir $tcl_library http*] -- cgit v0.12 From 9f9a9e291d8ef1d9d6183a445c9fe19374261c4d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 13:18:49 +0000 Subject: Change ULLONG_MAX -> UWIDE_MAX, LLONG_MAX -> WIDE_MAX and LLONG_MIN -> WIDE_MIN everywhere, because not all platforms equal Tcl_WideInt type as equal to "long long". This should fix test-cases on platforms where Tcl_WideInt != long long, and have no effect on 'normal' platforms --- generic/tclBasic.c | 4 ++-- generic/tclExecute.c | 32 ++++++++++++++++---------------- generic/tclPort.h | 3 ++- generic/tclScan.c | 4 ++-- 4 files changed, 22 insertions(+), 21 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 84ac87b..1abeeb4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7516,7 +7516,7 @@ ExprAbsFunc( } } goto unChanged; - } else if (l == LLONG_MIN) { + } else if (l == WIDE_MIN) { TclInitBignumFromWideInt(&big, l); goto tooLarge; } @@ -7641,7 +7641,7 @@ ExprEntierFunc( if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)LLONG_MAX) || (d <= (double)LLONG_MIN)) { + if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 82de752..cc4da9b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5635,17 +5635,17 @@ TEBCresume( if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; } else if (type1 == TCL_NUMBER_WIDE) { - /* value is between LLONG_MIN and LLONG_MAX */ + /* value is between WIDE_MIN and WIDE_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ - /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } } else if (type1 == TCL_NUMBER_BIG) { - /* value is an integer outside the LLONG_MIN to LLONG_MAX range */ - /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */ + /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ Tcl_WideInt w; if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { @@ -6061,9 +6061,9 @@ TEBCresume( TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w1 == LLONG_MIN) && (w2 == -1)) { + } else if ((w1 == WIDE_MIN) && (w2 == -1)) { /* - * Can't represent (-LLONG_MIN) as a Tcl_WideInt. + * Can't represent (-WIDE_MIN) as a Tcl_WideInt. */ goto overflow; @@ -6196,7 +6196,7 @@ TEBCresume( NEXT_INST_F(1, 0, 0); case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *) ptr1); - if (w1 != LLONG_MIN) { + if (w1 != WIDE_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); @@ -8670,10 +8670,10 @@ ExecuteExtendedBinaryMathOp( } /* - * Need a bignum to represent (LLONG_MIN / -1) + * Need a bignum to represent (WIDE_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { + if ((w1 == WIDE_MIN) && (w2 == -1)) { goto overflowBasic; } wResult = w1 / w2; @@ -8776,7 +8776,7 @@ ExecuteExtendedUnaryMathOp( DOUBLE_RESULT(-(*((const double *) ptr))); case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); - if (w != LLONG_MIN) { + if (w != WIDE_MIN) { WIDE_RESULT(-w); } TclInitBignumFromWideInt(&big, w); @@ -8862,10 +8862,10 @@ TclCompareTwoNumbers( * integer comparison can tell the difference. */ - if (d2 < (double)LLONG_MIN) { + if (d2 < (double)WIDE_MIN) { return MP_GT; } - if (d2 > (double)LLONG_MAX) { + if (d2 > (double)WIDE_MAX) { return MP_LT; } w2 = (Tcl_WideInt) d2; @@ -8895,10 +8895,10 @@ TclCompareTwoNumbers( || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } - if (d1 < (double)LLONG_MIN) { + if (d1 < (double)WIDE_MIN) { return MP_LT; } - if (d1 > (double)LLONG_MAX) { + if (d1 > (double)WIDE_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; @@ -8908,7 +8908,7 @@ TclCompareTwoNumbers( return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LLONG_MAX) && (d1 > (double)LLONG_MIN)) { + if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) { if (mp_isneg(&big2)) { compare = MP_GT; } else { @@ -8941,7 +8941,7 @@ TclCompareTwoNumbers( mp_clear(&big1); return compare; } - if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) { + if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; diff --git a/generic/tclPort.h b/generic/tclPort.h index 33c0db6..d3f6233 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -24,7 +24,8 @@ #endif #include "tcl.h" -#define WIDE_MAX ((Tcl_WideInt)((~(Tcl_WideUInt)0) >> 1)) +#define UWIDE_MAX ((Tcl_WideUInt)-1) +#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) #endif /* _TCLPORT */ diff --git a/generic/tclScan.c b/generic/tclScan.c index 0e3da17..733409e 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -926,9 +926,9 @@ Tcl_ScanObjCmd( } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = LLONG_MAX; + wideValue = WIDE_MAX; if (TclGetString(objPtr)[0] == '-') { - wideValue = LLONG_MIN; + wideValue = WIDE_MIN; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { -- cgit v0.12 From fbdc68b6a22a1be2c7923c6a2ab13214d3655aba Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 22 Sep 2018 16:51:43 +0000 Subject: Handle the (unlikely) case that Tcl_DStringSetLength() results in a re-allocation of the buffer --- generic/tclStubInit.c | 1 + win/tclWin32Dll.c | 1 + 2 files changed, 2 insertions(+) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index cb33288..66ad753 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -276,6 +276,7 @@ Tcl_WinTCharToUtf( memmove(r+2, r+1, p-r+size-1); memcpy(r++, "\xC0\x80", 2); Tcl_DStringSetLength(dsPtr, ++size + 1); + r = p = (char *)Tcl_DStringValue(dsPtr); } ++r; } diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 2216a66..13a3dec 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -524,6 +524,7 @@ Tcl_WinTCharToUtf( memmove(r+2, r+1, p-r+size-1); memcpy(r++, "\xC0\x80", 2); Tcl_DStringSetLength(dsPtr, ++size + 1); + r = p = (char *)Tcl_DStringValue(dsPtr); } ++r; } -- cgit v0.12 From 6d3aeef45e68dc92f69195ab165ce49ecd4738c4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Sep 2018 13:27:14 +0000 Subject: Give lambda function a name "ReceiveChunked" for easier testing. New function quoteString and code cleanup --- doc/exec.n | 6 +- doc/http.n | 18 ++++-- library/http/http.tcl | 142 ++++++++++++++--------------------------------- tests/httpPipeline.test | 2 +- tests/httpTestScript.tcl | 2 +- tests/winPipe.test | 6 +- win/tclWinPipe.c | 8 +-- 7 files changed, 67 insertions(+), 117 deletions(-) diff --git a/doc/exec.n b/doc/exec.n index d78c34a..99dfdc5 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -224,10 +224,10 @@ Although it is the common escape algorithm, but, in fact, the way how the executable parses the command-line (resp. splits it into single arguments) is decisive. .PP -Unfortunately, there is currently no way to supply newline character within -an argument to the batch files (\fB.cmd\fR or \fB.bat\fR) or to the command +Unfortunately, there is currently no way to supply newline character within +an argument to the batch files (\fB.cmd\fR or \fB.bat\fR) or to the command processor (\fBcmd.exe /c\fR), because this causes truncation of command-line -(also the argument chain) on the first newline character. +(also the argument chain) on the first newline character. But it works properly with an executable (using CommandLineToArgv, etc). .PP The Tk console text widget does not provide real standard IO capabilities. diff --git a/doc/http.n b/doc/http.n index e788022..7e633b3 100644 --- a/doc/http.n +++ b/doc/http.n @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "http" n 2.8 http "Tcl Bundled Packages" +.TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -22,6 +22,8 @@ http \- Client-side implementation of the HTTP/1.1 protocol .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? .sp +\fB::http::quoteString\fR \fIvalue\fR +.sp \fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? .sp \fB::http::wait \fItoken\fR @@ -146,12 +148,13 @@ default is 0. \fB\-urlencoding\fR \fIencoding\fR . The \fIencoding\fR used for creating the x-url-encoded URLs with -\fB::http::formatQuery\fR. The default is \fButf-8\fR, as specified by RFC +\fB::http::formatQuery\fR and \fB::http::quoteString\fR. +The default is \fButf-8\fR, as specified by RFC 2718. Prior to http 2.5 this was unspecified, and that behavior can be returned by specifying the empty string (\fB{}\fR), although \fIiso8859-1\fR is recommended to restore similar behavior but without the -\fB::http::formatQuery\fR throwing an error processing non-latin-1 -characters. +\fB::http::formatQuery\fR or \fB::http::quoteString\fR +throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\fR . @@ -375,6 +378,11 @@ encodes the keys and values, and generates one string that has the proper & and = separators. The result is suitable for the \fB\-query\fR value passed to \fB::http::geturl\fR. .TP +\fB::http::quoteString\fR \fIvalue\fR +. +This procedure does x-url-encoding of string. It takes a single argument and +encodes it. +.TP \fB::http::reset\fR \fItoken\fR ?\fIwhy\fR? . This command resets the HTTP transaction identified by \fItoken\fR, if any. @@ -755,7 +763,7 @@ Option \fB-postfresh\fR, if boolean \fBtrue\fR, will override the \fBhttp::getur .PP Option \fB-repost\fR, if \fBtrue\fR, permits automatic retry of a POST request that fails because it uses a persistent connection that the server has -half-closed (an +half-closed (an .QW "asynchronous close event" ). Subsequent GET and HEAD requests in a failed pipeline will also be retried. \fIThe -repost option should be used only if the application understands diff --git a/library/http/http.tcl b/library/http/http.tcl index 643a119..f82bced 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -100,7 +100,6 @@ namespace eval http { array set socketWrQueue {} array set socketClosing {} array set socketPlayCmd {} - return } init @@ -128,7 +127,7 @@ namespace eval http { set defaultKeepalive 0 } - namespace export geturl config reset wait formatQuery + namespace export geturl config reset wait formatQuery quoteString namespace export register unregister registerError # - Useful, but not exported: data, size, status, code, cleanup, error, # meta, ncode, mapReply, init. Comments suggest that "init" can be used @@ -161,7 +160,6 @@ if {[info command http::Log] eq {}} {proc http::Log {args} {}} proc http::register {proto port command} { variable urlTypes set urlTypes([string tolower $proto]) [list $port $command] - # N.B. Implicit Return. } # http::unregister -- @@ -219,7 +217,6 @@ proc http::config {args} { } set http($flag) $value } - return } } @@ -293,8 +290,6 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { } { http::CloseQueuedQueries $connId $token } - - return } # http::KeepSocket - @@ -335,9 +330,6 @@ proc http::KeepSocket {token} { # ONLY for testing reaction to server eof. # No server timeouts will be caught. catch {fileevent $state(sock) readable {}} - } else { - # Normal operation. - # Test constraint normalEof. } if { [info exists state(socketinfo)] @@ -386,7 +378,7 @@ proc http::KeepSocket {token} { # socketWrState has been marked "pending" (in # http::NextPipelinedWrite or http::geturl) so a new pipelined # request cannot jump the queue. - # + # # Tests: # - In this case the read queue (tested above) is empty and this # "pending" write token is in front of the rest of the write @@ -476,8 +468,6 @@ proc http::KeepSocket {token} { } elseif {(!$state(-pipeline))} { set socketWrState($connId) Wready # Rready and Wready and idle: nothing to do. - } else { - # Rready and idle: nothing to do. } } else { @@ -485,7 +475,6 @@ proc http::KeepSocket {token} { # There is no socketMapping($state(socketinfo)), so it does not matter # that CloseQueuedQueries is not called. } - return } # http::CheckEof - @@ -511,7 +500,6 @@ proc http::CheckEof {sock} { # will then be error-handled. CloseSocket $sock } - return } # http::CloseSocket - @@ -539,7 +527,6 @@ proc http::CloseSocket {s {token {}}} { upvar 0 $token state if {[info exists state(socketinfo)]} { set connId $state(socketinfo) - } else { } } else { set map [array get socketMapping] @@ -547,7 +534,6 @@ proc http::CloseSocket {s {token {}}} { if {$ndx != -1} { incr ndx -1 set connId [lindex $map $ndx] - } else { } } if { ($connId ne {}) @@ -557,22 +543,18 @@ proc http::CloseSocket {s {token {}}} { Log "Closing connection $connId (sock $socketMapping($connId))" if {[catch {close $socketMapping($connId)} err]} { Log "Error closing connection: $err" - } else { } if {$token eq {}} { # Cases with a non-empty token are handled by Finish, so the tokens # are finished in connection order. http::CloseQueuedQueries $connId - } else { } } else { Log "Closing socket $s (no connection info)" if {[catch {close $s} err]} { Log "Error closing socket: $err" - } else { } } - return } # http::CloseQueuedQueries @@ -629,7 +611,6 @@ proc http::CloseQueuedQueries {connId {token {}}} { - token $token {*}$unfinished } - return } # http::Unset @@ -655,8 +636,6 @@ proc http::Unset {connId} { unset -nocomplain socketWrQueue($connId) unset -nocomplain socketClosing($connId) unset -nocomplain socketPlayCmd($connId) - - return } # http::reset -- @@ -682,7 +661,6 @@ proc http::reset {token {why reset}} { unset state eval ::error $errorlist } - return } # http::geturl -- @@ -1248,9 +1226,6 @@ proc http::geturl {url args} { #Log re-use nonpipeline, GRANT r/w access to $token in geturl set socketRdState($state(socketinfo)) $token set socketWrState($state(socketinfo)) $token - - } else { - # (!$reusing) } # All (!$reusing) cases come here, and also some $reusing cases if the @@ -1528,17 +1503,12 @@ proc http::Connected {token proto phost srvurl} { registerError $sock {} if {$msg eq {}} { set msg {failed to use socket} - } else { } Finish $token $msg } elseif {$state(status) ne "error"} { Finish $token $err - } else { - # if state(status) is error, it means someone's already called - # Finish to do the above-described clean up. } } - return } # http::registerError @@ -1567,7 +1537,6 @@ proc http::registerError {sock args} { return } set registeredErrors($sock) {*}$args - # N.B. Implicit Return } # http::DoneRequest -- @@ -1645,7 +1614,6 @@ proc http::DoneRequest {token} { # In the nonpipeline case, connection for reading always occurs. ReceiveResponse $token } - return } # http::ReceiveResponse @@ -1666,7 +1634,6 @@ proc http::ReceiveResponse {token} { coroutine ${token}EventCoroutine http::Event $sock $token fileevent $sock readable ${token}EventCoroutine - return } # http::NextPipelinedWrite @@ -1778,12 +1745,7 @@ proc http::NextPipelinedWrite {token} { #Log re-use nonpipeline, GRANT delayed write access to $token in NextP.. set socketWrState($connId) peNding - - } else { - # No requests in socketWrQueue. Nothing to do. } - - return } # http::CancelReadPipeline @@ -1816,7 +1778,6 @@ proc http::CancelReadPipeline {name1 connId op} { } set socketRdQueue($connId) {} } - return } # http::CancelWritePipeline @@ -1850,7 +1811,6 @@ proc http::CancelWritePipeline {name1 connId op} { } set socketWrQueue($connId) {} } - return } # http::ReplayIfDead -- @@ -1907,7 +1867,6 @@ proc http::ReplayIfDead {tokenArg doing} { lappend InFlightR $socketRdState($stateArg(socketinfo)) } elseif {($doing eq "read")} { lappend InFlightR $tokenArg - } else { } if { [info exists socketWrState($stateArg(socketinfo))] @@ -1916,7 +1875,6 @@ proc http::ReplayIfDead {tokenArg doing} { lappend InFlightW $socketWrState($stateArg(socketinfo)) } elseif {($doing eq "write")} { lappend InFlightW $tokenArg - } else { } # Report any inconsistency of $tokenArg with socket*state. @@ -1936,7 +1894,6 @@ proc http::ReplayIfDead {tokenArg doing} { Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \ ne socketWrState($stateArg(socketinfo)) \ $socketWrState($stateArg(socketinfo)) - } else { } } else { # One transaction should be in flight. @@ -1948,7 +1905,6 @@ proc http::ReplayIfDead {tokenArg doing} { Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ ne socketRdState($stateArg(socketinfo)) \ $socketRdState($stateArg(socketinfo)) - } else { } # Report the inconsistency that socketRdQueue is non-empty. @@ -1958,7 +1914,6 @@ proc http::ReplayIfDead {tokenArg doing} { Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \ has read queue socketRdQueue($stateArg(socketinfo)) \ $socketRdQueue($stateArg(socketinfo)) ne {} - } else { } lappend InFlightW $socketRdState($stateArg(socketinfo)) @@ -1989,7 +1944,6 @@ proc http::ReplayIfDead {tokenArg doing} { # to new values in ReplayCore. ReplayCore $newQueue - return } # http::ReplayIfClose -- @@ -2029,7 +1983,6 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} { # 2. Cleanup - none needed, done by the caller. ReplayCore $newQueue - return } # http::ReInit -- @@ -2236,7 +2189,6 @@ proc http::ReplayCore {newQueue} { # Connect does its own fconfigure. fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs] #Log ---- $sock << conn to $token for HTTP request (e) - return } # Data access functions: @@ -2314,7 +2266,6 @@ proc http::cleanup {token} { if {[info exists state]} { unset state } - return } # http::Connect @@ -2358,7 +2309,6 @@ proc http::Connect {token proto phost srvurl} { fileevent $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl } - return } # http::Write @@ -2463,7 +2413,6 @@ proc http::Write {token} { eval $state(-queryprogress) \ [list $token $state(querylength) $state(queryoffset)] } - return } # http::Event @@ -2560,10 +2509,6 @@ proc http::Event {sock token} { # last use. # If any other requests are in flight or pipelined/queued, they # will be discarded. - } else { - ##Log - connecting 2 - token $token - # nsl is -1 so either fblocked (OK) or (eof and not reusing). - # Continue. Any eof is processed at the end of this proc. } } elseif {$state(state) eq "header"} { if {[catch {gets $sock line} nhl]} { @@ -2795,7 +2740,6 @@ proc http::Event {sock token} { set n 0 set state(state) complete } - } else { } } elseif {[info exists state(transfer_final)]} { # This code forgives EOF in place of the final CRLF. @@ -2955,11 +2899,8 @@ proc http::Event {sock token} { } } elseif {$cc} { return - } else { - # Not eof, continue and yield. } } - return } # http::TestForReplay @@ -3148,7 +3089,6 @@ proc http::CopyStart {sock token {initial 1}} { Finish $token $err } } - return } proc http::CopyChunk {token chunk} { @@ -3178,7 +3118,6 @@ proc http::CopyChunk {token chunk} { } Eot $token ;# FIX ME: pipelining. } - return } # http::CopyDone @@ -3209,7 +3148,6 @@ proc http::CopyDone {token count {error {}}} { } else { CopyStart $sock $token 0 } - return } # http::Eot @@ -3279,7 +3217,6 @@ proc http::Eot {token {reason {}}} { } } Finish $token $reason - return } # http::wait -- @@ -3317,6 +3254,12 @@ proc http::wait {token} { # TODO 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.} + } set result "" set sep "" foreach i $args { @@ -3361,6 +3304,7 @@ proc http::mapReply {string} { } return $converted } +interp alias {} http::quoteString {} http::mapReply # http::ProxyRequired -- # Default proxy filter. @@ -3382,7 +3326,6 @@ proc http::ProxyRequired {host} { } return [list $http(-proxyhost) $http(-proxyport)] } - return } # http::CharsetToEncoding -- @@ -3436,8 +3379,7 @@ proc http::ContentEncoding {token} { compress - x-compress { lappend r decompress } identity {} default { - set msg "unsupported content-encoding \"$coding\"" - return -code error $msg + return -code error "unsupported content-encoding \"$coding\"" } } } @@ -3445,39 +3387,39 @@ proc http::ContentEncoding {token} { return $r } -proc http::make-transformation-chunked {chan command} { - set lambda {{chan command} { - set data "" - set size -1 - yield - while {1} { - chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } - chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { - return -code error "invalid size: \"$line\"" - } - set chunk "" - while {$size && ![chan eof $chan]} { - set part [chan read $chan $size] - incr size -[string length $part] - append chunk $part - } - if {[catch { - uplevel #0 [linsert $command end $chunk] - }]} { - http::Log "Error in callback: $::errorInfo" - } - if {[string length $chunk] == 0} { - # channel might have been closed in the callback - catch {chan event $chan readable {}} - return - } +proc http::ReceiveChunked {chan command} { + set data "" + set size -1 + yield + while {1} { + chan configure $chan -translation {crlf binary} + while {[gets $chan line] < 1} { yield } + chan configure $chan -translation {binary binary} + if {[scan $line %x size] != 1} { + return -code error "invalid size: \"$line\"" + } + set chunk "" + while {$size && ![chan eof $chan]} { + set part [chan read $chan $size] + incr size -[string length $part] + append chunk $part + } + if {[catch { + uplevel #0 [linsert $command end $chunk] + }]} { + http::Log "Error in callback: $::errorInfo" + } + if {[string length $chunk] == 0} { + # channel might have been closed in the callback + catch {chan event $chan readable {}} + return } - }} - coroutine dechunk$chan ::apply $lambda $chan $command - chan event $chan readable [namespace origin dechunk$chan] - return + } +} + +proc http::make-transformation-chunked {chan command} { + coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command + chan event $chan readable [namespace current]::dechunk$chan } # Local variables: diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 5eb02d3..8de79b9 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -532,7 +532,7 @@ proc ReturnTestScriptAndResult {ca cb delay te} { # Proc MakeMessage # ------------------------------------------------------------------------------ # WHD's one-line command to generate multi-line strings from readable code. -# +# # Example: # set blurb [MakeMessage { # |This command allows multi-line strings to be created with readable diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index a8ef9c8..a40449a 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -496,7 +496,7 @@ proc httpTestScript::runHttpTestScript {scr} { proc httpTestScript::cleanupHttpTestScript {} { variable TimeOutDone variable RequestsWhenStopped - + if {![info exists RequestsWhenStopped]} { return -code error {Cleanup Failed: RequestsWhenStopped is undefined} } diff --git a/tests/winPipe.test b/tests/winPipe.test index 9402db1..62cc707 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -41,7 +41,7 @@ append big $big append big $big set path(little) [makeFile {} little] -set f [open $path(little) w] +set f [open $path(little) w] puts -nonewline $f "little" close $f @@ -332,7 +332,7 @@ proc _testExecArgs {single args} { set broken {} foreach args $args { if {$single & 1} { - # enclose single test-arg between 1st/3rd to be sure nothing is truncated + # enclose single test-arg between 1st/3rd to be sure nothing is truncated # (e. g. to cover unexpected trim by nts-zero case, and args don't recombined): set args [list "1st" $args "3rd"] } @@ -569,7 +569,7 @@ set injectList { test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args} \ -constraints {win exec} -body { - # test exe only, because currently there is no proper way to escape a new-line char resp. + # test exe only, because currently there is no proper way to escape a new-line char resp. # to supply a new-line to the batch-files within arguments (command line is truncated). _testExecArgs 8 \ [list START {*}$injectList END] \ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index dd54a27..826265a 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1495,10 +1495,10 @@ QuoteCmdLinePart( QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } - /* - * escape all special chars enclosed in quotes like `"..."`, note that here we + /* + * escape all special chars enclosed in quotes like `"..."`, note that here we * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as + * so `\` remains `\`, but important - not at end of part, because results as * before the quote, so `%\%\` should be escaped as `"%\%"\\`). */ TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ @@ -1653,7 +1653,7 @@ BuildCommandLine( special++; } /* rest of argument (and escape backslashes before closing main quote) */ - QuoteCmdLineBackslash(&ds, start, special, + QuoteCmdLineBackslash(&ds, start, special, (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { -- cgit v0.12 From be629669a54f0106c40f0bcb78f4493b481d61c6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 23 Sep 2018 17:29:46 +0000 Subject: Added docs --- doc/append.n | 12 +++++++++--- doc/array.n | 53 ++++++++++++++++++++++++++++++++++++++++++++++++++++- doc/dict.n | 35 +++++++++++++++++++++++++++++++++++ doc/incr.n | 9 +++++++++ doc/lappend.n | 10 ++++++++++ 5 files changed, 115 insertions(+), 4 deletions(-) diff --git a/doc/append.n b/doc/append.n index e3bf224..99b4ece 100644 --- a/doc/append.n +++ b/doc/append.n @@ -20,6 +20,11 @@ Append all of the \fIvalue\fR arguments to the current value of variable \fIvarName\fR. If \fIvarName\fR does not exist, it is given a value equal to the concatenation of all the \fIvalue\fR arguments. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, the concatenation of the default value and all the +\fIvalue\fR arguments will be stored in the array element. +.VE TIP508 The result of this command is the new value stored in variable \fIvarName\fR. This command provides an efficient way to build up long @@ -44,6 +49,7 @@ puts $var concat(n), lappend(n) .SH KEYWORDS append, variable -'\" Local Variables: -'\" mode: nroff -'\" End: +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/array.n b/doc/array.n index d6d4dff..bbfcd9f 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH array n 8.3 Tcl "Tcl Built-In Commands" +.TH array n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -36,6 +36,53 @@ with an empty name, since the return value from \fBarray nextelement\fR will not indicate whether the search has been completed. .TP +\fBarray default \fIsubcommand arrayName args...\fR +.VS TIP508 +Manages the default value of the array. Arrays initially have no default +value, but this command allows you to set one; the default value will be +returned when reading from an element of the array \farrayName\fR if the read +would otherwise result in an error. Note that this may cause the \fBappend\fR, +\fBdict\fR, \fBincr\fR and \fBlappend\fR commands to change their behavior in +relation to non-existing array elements. +.RS +.PP +The \fIsubcommand\fR argument controls what exact operation will be performed +on the default value of \fIarrayName\fR. Supported \fIsubcommand\fRs are: +.VE TIP508 +.TP +\fBarray default exists \fIarrayName\fR +.VS TIP508 +This returns a boolean value indicating whether a default value has been set +for the array \fIarrayName\fR. Returns a false value if \fIarrayName\fR does +not exist. Raises an error if \fIarrayName\fR is an existing variable that is +not an array. +.VE TIP508 +.TP +\fBarray default get \fIarrayName\fR +.VS TIP508 +This returns the current default value for the array \fIarrayName\fR. Raises +an error if \fIarrayName\fR is an existing variable that is not an array, or +if \fIarrayName\fR is an array without a default value. +.VE TIP508 +.TP +\fBarray default set \fIarrayName value\fR +.VS TIP508 +This sets the default value for the array \fIarrayName\fR to \fIvalue\fR. +Returns the empty string. Raises an error if \fIarrayName\fR is an existing +variable that is not an array, or if \fIarrayName\fR is an illegal name for an +array. If \fIarrayName\fR does not currently exist, it is created as an empty +array as well as having its default value set. +.VE TIP508 +.TP +\fBarray default unset \fIarrayName\fR +.VS TIP508 +This removes the default value for the array \fIarrayName\fR and returns the +empty string. Does nothing if \fIarrayName\fR does not have a default +value. Raises an error if \fIarrayName\fR is an existing variable that is not +an array. +.VE TIP508 +.RE +.TP \fBarray donesearch \fIarrayName searchId\fR This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates @@ -194,3 +241,7 @@ foreach color [lsort [\fBarray names\fR colorcount]] { list(n), string(n), variable(n), trace(n), foreach(n) .SH KEYWORDS array, element names, search +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/dict.n b/doc/dict.n index cd7e94c..1829768 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -27,6 +27,11 @@ key maps to in the dictionary value contained in the given variable, writing the resulting dictionary value back to that variable. Non-existent keys are treated as if they map to an empty string. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the appending operation. +.VE TIP508 .TP \fBdict create \fR?\fIkey value ...\fR? . @@ -124,6 +129,11 @@ resulting dictionary value back to that variable. Non-existent keys are treated as if they map to 0. It is an error to increment a value for an existing key if that value is not an integer. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the incrementing operation. +.VE TIP508 .TP \fBdict info \fIdictionaryValue\fR . @@ -149,6 +159,11 @@ keys are treated as if they map to an empty list, and it is legal for there to be no items to append to the list. It is an error for the value that the key maps to to not be representable as a list. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the list-appending operation. +.VE TIP508 .TP \fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR . @@ -206,6 +221,11 @@ value and places an updated dictionary value in that variable containing a mapping from the given key to the given value. When multiple keys are present, this operation creates or updates a chain of nested dictionaries. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the value insert/update operation. +.VE TIP508 .TP \fBdict size \fIdictionaryValue\fR . @@ -221,6 +241,11 @@ through nested dictionaries to the mapping to remove. At least one key must be specified, but the last key on the key-path need not exist. All other components on the path must exist. The updated dictionary value is returned. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the value remove operation. +.VE TIP508 .TP \fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR . @@ -236,6 +261,11 @@ are silently discarded), even if the result of \fIbody\fR is an error or some other kind of exceptional exit. The result of \fBdict update\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the update operation. +.VE TIP508 .RS .PP Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR; @@ -270,6 +300,11 @@ dictionary be discarded, and this also happens if the contents of dictionaries no longer exists. The result of \fBdict with\fR is (unless some kind of error occurs) the result of the evaluation of \fIbody\fR. +.VS TIP508 +If \fIdictionaryVarable\fR indicates an element that does not exist of an +array that has a default value set, the default value and will be used as the +value of the dictionary prior to the updating operation. +.VE TIP508 .RS .PP The variables are mapped in the scope enclosing the \fBdict with\fR; diff --git a/doc/incr.n b/doc/incr.n index b4be95c..f491903 100644 --- a/doc/incr.n +++ b/doc/incr.n @@ -27,6 +27,11 @@ and also returned as result. Starting with the Tcl 8.5 release, the variable \fIvarName\fR passed to \fBincr\fR may be unset, and in that case, it will be set to the value \fIincrement\fR or to the default increment value of \fB1\fR. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, the sum of the default value and the \fIincrement\fR (or +1) will be stored in the array element. +.VE TIP508 .SH EXAMPLES .PP Add one to the contents of the variable \fIx\fR: @@ -59,3 +64,7 @@ an error if it is not): expr(n), set(n) .SH KEYWORDS add, increment, variable, value +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/lappend.n b/doc/lappend.n index 80d075a..66bea5f 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -22,6 +22,12 @@ and appends each of the \fIvalue\fR arguments to that list as a separate element, with spaces between elements. If \fIvarName\fR does not exist, it is created as a list with elements given by the \fIvalue\fR arguments. +.VS TIP508 +If \fIvarName\fR indicate an element that does not exist of an array that has +a default value set, list that is comprised of the default value with all the +\fIvalue\fR arguments appended as elements will be stored in the array +element. +.VE TIP508 \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up @@ -47,3 +53,7 @@ list(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12 From 4719e1f68dfa2eefb9988043ea2baa81dbe7ebe5 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 24 Sep 2018 08:21:36 +0000 Subject: Add tests. Exposes quite a few bugs in the implementation... --- tests/var.test | 190 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 189 insertions(+), 1 deletion(-) diff --git a/tests/var.test b/tests/var.test index 7b7fc25..a05106f 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1046,7 +1046,7 @@ test var-22.2 {leak in parsedVarName} -constraints memory -body { } -cleanup { unset -nocomplain i x } -result 0 - + unset -nocomplain a k v test var-23.1 {array command, for loop, too many args} -returnCodes error -body { array for {k v} c d e {} @@ -1202,6 +1202,194 @@ test var-23.14 {array for, shared arguments} -setup { } -cleanup { unset -nocomplain $vn vn } -result {} + +test var-24.1 {array default set and get: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] +} -cleanup { + unset -nocomplain ary +} -result {3 7 1 0 7} +test var-24.2 {array default set and get: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] + }} +} {3 7 1 0 7} +test var-24.3 {array default unset: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] +} -cleanup { + unset -nocomplain ary +} -result {3 7 {} 3 1} +test var-24.4 {array default unset: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) \ + [catch {set ary(b)}] + }} +} {3 7 {} 3 1} +test var-24.5 {array default exists: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] +} -cleanup { + unset -nocomplain ary result +} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.6 {array default exists: compiled} { + apply {{} { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] + }} +} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.7 {array default and append: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.8 {array default and append: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.9 {array default and lappend: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.10 {array default and lappend: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.11 {array default and incr: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 18 2 19 1} +test var-24.12 {array default and incr: compiled} { + apply {{} { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 18 2 19 1} +test var-24.13 {array default and dict: interpreted} -setup { + unset -nocomplain ary x y z +} -body { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + lsort -stride 2 -index 0 [array get ary] +} -cleanup { + unset -nocomplain ary x y z +} -result {p {x {y z}} q {x z} r {x 123}} +test var-24.14 {array default and dict: compiled} { + lsort -stride 2 -index 0 [apply {{} { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + array get ary + }}] +} {p {x {y z}} q {x z} r {x 123}} +test var-24.15 {array default set and get: two-level} { + apply {{} { + array set ary {a 3} + array default set ary 7 + apply {{} { + upvar 1 ary ary ary(c) c + lappend result $ary(a) $ary(b) $c + lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] + lappend result [array default get ary] + }} + }} +} {3 7 7 1 0 0 7} catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From 338b9ec9d27a63172d899b020d77c00abc84590c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 24 Sep 2018 16:15:25 +0000 Subject: Silence debugging message in test suite. --- tests/httpTest.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 9cd7a5d..326b361 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -25,7 +25,7 @@ package require http namespace eval ::http { variable TestStartTimeInMs [clock milliseconds] - catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"} +# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"} } namespace eval ::httpTest { -- cgit v0.12 From ac61d77a4196e4243153563d9cae24f2f20550bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Sep 2018 23:24:00 +0000 Subject: More fixes in Tcl_WinTChar2Utf: Don't restart loop when output contains null-byte. --- generic/tclStubInit.c | 18 +++++++++--------- win/tclWin32Dll.c | 18 +++++++++--------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 66ad753..6614764 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -258,8 +258,8 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { - char *p, *r; - int size; + char *p; + int size, i = 0; if (len > 0) { len /= 2; @@ -267,18 +267,18 @@ Tcl_WinTCharToUtf( size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); Tcl_DStringInit(dsPtr); Tcl_DStringSetLength(dsPtr, size+8); /* Add some spare, in case of NULL-bytes */ - r = p = (char *)Tcl_DStringValue(dsPtr); + p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); if (len == -1) --size; /* account for 0-byte at string end */ - while (r < p+size) { - if (!*r) { + while (i < size) { + if (!p[i]) { /* Output contains '\0'-byte, but Tcl expect two-bytes: C0 80 */ - memmove(r+2, r+1, p-r+size-1); - memcpy(r++, "\xC0\x80", 2); + memmove(p+i+2, p+i+1, size-i-1); + memcpy(p + i++, "\xC0\x80", 2); Tcl_DStringSetLength(dsPtr, ++size + 1); - r = p = (char *)Tcl_DStringValue(dsPtr); + p = (char *)Tcl_DStringValue(dsPtr); } - ++r; + ++i; } Tcl_DStringSetLength(dsPtr, size); p[size] = 0; diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 13a3dec..60edbab 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -506,8 +506,8 @@ Tcl_WinTCharToUtf( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - char *p, *r; - int size; + char *p; + int size, i = 0; if (len > 0) { len /= 2; @@ -515,18 +515,18 @@ Tcl_WinTCharToUtf( size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); Tcl_DStringInit(dsPtr); Tcl_DStringSetLength(dsPtr, size+8); /* Add some spare, in case of NULL-bytes */ - r = p = (char *)Tcl_DStringValue(dsPtr); + p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); if (len == -1) --size; /* account for 0-byte at string end */ - while (r < p+size) { - if (!*r) { + while (i < size) { + if (!p[i]) { /* Output contains '\0'-byte, but Tcl expect two-bytes: C0 80 */ - memmove(r+2, r+1, p-r+size-1); - memcpy(r++, "\xC0\x80", 2); + memmove(p+i+2, p+i+1, size-i-1); + memcpy(p + i++, "\xC0\x80", 2); Tcl_DStringSetLength(dsPtr, ++size + 1); - r = p = (char *)Tcl_DStringValue(dsPtr); + p = (char *)Tcl_DStringValue(dsPtr); } - ++r; + ++i; } Tcl_DStringSetLength(dsPtr, size); p[size] = 0; -- cgit v0.12 From 76e2e078e32be366597a31936f3661b3ab42d93e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:24:44 +0000 Subject: Correct variable existence check in [array default exists] --- generic/tclVar.c | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 092d902..6bcd8d8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -247,7 +247,6 @@ static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL }; - Var * TclVarHashCreateVar( @@ -6572,7 +6571,8 @@ ArrayDefaultCmd( */ CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(arrayNameObj), NULL); return TCL_ERROR; @@ -6600,12 +6600,16 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (varPtr && !isArray) { - return NotArrayError(interp, arrayNameObj); - } - if (!varPtr) { + /* + * Undefined variables (whether or not they have storage allocated) do + * not have defaults, and this is not an error case. + */ + + if (!varPtr || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else if (!isArray) { + return NotArrayError(interp, arrayNameObj); } else { defaultValueObj = GetArrayDefault(varPtr); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); -- cgit v0.12 From 7b0e9cef6051f9c59269659da34e1744d074080e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:27:31 +0000 Subject: More correct variable existence checks --- generic/tclVar.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 6bcd8d8..fbe43ac 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -6535,7 +6535,7 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (!varPtr || !isArray) { + if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { return NotArrayError(interp, arrayNameObj); } @@ -6621,11 +6621,11 @@ ArrayDefaultCmd( Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; } - if (varPtr && !isArray) { - return NotArrayError(interp, arrayNameObj); - } - - if (varPtr) { + + if (varPtr && !TclIsVarUndefined(varPtr)) { + if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } SetArrayDefault(varPtr, NULL); } return TCL_OK; -- cgit v0.12 From beac2287a9fc876159823c0ca79d713b7851ddae Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 07:36:09 +0000 Subject: Corrected the semantics of [append] with defaults --- generic/tclVar.c | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index fbe43ac..ec48984 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1907,8 +1907,27 @@ TclPtrSetVarIdx( */ if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + } else { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } + } else { + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + } } else { if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); -- cgit v0.12 From b1f92f488848d8c4cba71716ecd0264bb976d00b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Sep 2018 10:18:32 +0000 Subject: Added test cases for errors --- tests/var.test | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) diff --git a/tests/var.test b/tests/var.test index a05106f..36beb3a 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1390,6 +1390,73 @@ test var-24.15 {array default set and get: two-level} { }} }} } {3 7 7 1 0 0 7} +test var-24.16 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default set ary 7 +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {can't array default set "ary": variable isn't array} +test var-24.17 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.18 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.19 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default get ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.20 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + array default get ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.21 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default exists ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.22 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + array default exists ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.23 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default unset ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.24 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + array default unset ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From d5583552c0832cc427f3717df34e19680e4d10e9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Sep 2018 21:16:32 +0000 Subject: Contributed patch from Gustaf Neumann, preventing problems where "localCachePtr" can be NULL --- generic/tclProc.c | 36 +++++++++++++++++++----------------- generic/tclVar.c | 53 ++++++++++++++++++++++++++++++----------------------- 2 files changed, 49 insertions(+), 40 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 232eb93..533b817 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1035,7 +1035,6 @@ ProcWrongNumArgs( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - register Var *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; @@ -1059,23 +1058,26 @@ ProcWrongNumArgs( } Tcl_IncrRefCount(desiredObjs[0]); - defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); - for (i=1 ; i<=numArgs ; i++, defPtr++) { - Tcl_Obj *argObj; - Tcl_Obj *namePtr = localName(framePtr, i-1); - - if (defPtr->value.objPtr != NULL) { - TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); - } else if (defPtr->flags & VAR_IS_ARGS) { - numArgs--; - final = "?arg ...?"; - break; - } else { - argObj = namePtr; - Tcl_IncrRefCount(namePtr); + if (localCt > 0) { + register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + + for (i=1 ; i<=numArgs ; i++, defPtr++) { + Tcl_Obj *argObj; + Tcl_Obj *namePtr = localName(framePtr, i-1); + + if (defPtr->value.objPtr != NULL) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "?arg ...?"; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; } - desiredObjs[i] = argObj; } Tcl_ResetResult(interp); diff --git a/generic/tclVar.c b/generic/tclVar.c index ed16c9f..7b3db7e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -972,20 +972,24 @@ TclLookupSimpleVar( } } } else { /* Local var: look in frame varFramePtr. */ - int localLen, localCt = varFramePtr->numCompiledLocals; - Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; - const char *localNameStr; + int localCt = varFramePtr->numCompiledLocals; - for (i=0 ; i 0) { + Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + const char *localNameStr; + int localLen; - if (objPtr) { - localNameStr = TclGetStringFromObj(objPtr, &localLen); + for (i=0 ; icompiledLocals[i]; + *indexPtr = i; + return (Var *) &varFramePtr->compiledLocals[i]; + } } } } @@ -6132,7 +6136,7 @@ AppendLocals( Interp *iPtr = (Interp *) interp; Var *varPtr; int i, localVarCt, added; - Tcl_Obj **varNamePtr, *objNamePtr; + Tcl_Obj *objNamePtr; const char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; @@ -6142,27 +6146,30 @@ AppendLocals( localVarCt = iPtr->varFramePtr->numCompiledLocals; varPtr = iPtr->varFramePtr->compiledLocals; localVarTablePtr = iPtr->varFramePtr->varTablePtr; - varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; if (includeLinks) { Tcl_InitObjHashTable(&addedTable); } - for (i = 0; i < localVarCt; i++, varNamePtr++) { - /* - * Skip nameless (temporary) variables and undefined variables. - */ + if (localVarCt > 0) { + Tcl_Obj **varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; + + for (i = 0; i < localVarCt; i++, varNamePtr++) { + /* + * Skip nameless (temporary) variables and undefined variables. + */ - if (*varNamePtr && !TclIsVarUndefined(varPtr) + if (*varNamePtr && !TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - varName = TclGetString(*varNamePtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); - if (includeLinks) { - Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + varName = TclGetString(*varNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + } } } + varPtr++; } - varPtr++; } /* -- cgit v0.12 From 3b77852126dd89aeae123f069e9e8b850b574f21 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 08:12:34 +0000 Subject: Fix semantics of [lappend] with defaults in a procedure. --- generic/tclVar.c | 178 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 126 insertions(+), 52 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index ec48984..6676c6c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1774,6 +1774,130 @@ TclPtrSetVar( /* *---------------------------------------------------------------------- * + * ListAppendInVar, StringAppendInVar -- + * + * Support functions for TclPtrSetVarIdx that implement various types of + * appending operations. + * + * Results: + * ListAppendInVar returns a Tcl result code (from the core list append + * operation). StringAppendInVar has no return value. + * + * Side effects: + * The variable or element of the array is updated. This may make the + * variable/element exist. Reference counts of values may be updated. + * + *---------------------------------------------------------------------- + */ + +static inline int +ListAppendInVar( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + if (oldValuePtr == NULL) { + /* + * No previous value. Check for defaults if there's an array we can + * ask this of. + */ + + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + oldValuePtr = Tcl_DuplicateObj(defValuePtr); + } + } + + if (oldValuePtr == NULL) { + /* + * No default. [lappend] semantics say this is like being an empty + * string. + */ + + TclNewObj(oldValuePtr); + } + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + + return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); +} + +static inline void +StringAppendInVar( + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + /* + * If there was no previous value, either we use the array's default (if + * this is an array with a default at all) or we treat this as a simple + * set. + */ + + if (oldValuePtr == NULL) { + if (arrayPtr) { + Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + + if (defValuePtr) { + /* + * This is *almost* the same as the shared path below, except + * that the original value reference in defValuePtr is not + * decremented. + */ + + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + return; + } + } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + return; + } + + /* + * We append newValuePtr's bytes but don't change its ref count. Unless + * the reference is shared, when we have to duplicate in order to be safe + * to modify at all. + */ + + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } +} + +/* + *---------------------------------------------------------------------- + * * TclPtrSetVarIdx -- * * This function is the same as Tcl_SetVar2Ex above, except that it @@ -1886,63 +2010,13 @@ TclPtrSetVarIdx( } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - result = Tcl_ListObjAppendElement(interp, oldValuePtr, + result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); - - if (defValuePtr) { - Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); - - varPtr->value.objPtr = valuePtr; - TclContinuationsCopy(valuePtr, defValuePtr); - Tcl_IncrRefCount(valuePtr); - Tcl_AppendObjToObj(valuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } else { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } - } else { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } - } else { - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } + StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); } } else if (newValuePtr != oldValuePtr) { /* -- cgit v0.12 From 761a7867d59650fe2a632e377c216fc8b39beaf3 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 13:08:46 +0000 Subject: Make defaults work even when [upvar]ed to just a non-existent element. --- generic/tclInt.h | 1 + generic/tclVar.c | 104 +++++++++++++++++++++++++++++++++-------------------- tests/set-old.test | 4 +-- 3 files changed, 69 insertions(+), 40 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 40fae04..d4992dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4142,6 +4142,7 @@ MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, */ MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); +MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); /* * Utility routines for encoding index values as integers. Used by both diff --git a/generic/tclVar.c b/generic/tclVar.c index b2cbebe..8860df5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -165,6 +165,18 @@ typedef struct ArraySearch { } ArraySearch; /* + * TIP #508: [array default] + * + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/* * Forward references to functions defined later in this file: */ @@ -205,7 +217,6 @@ static int ArrayDefaultCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void DeleteArrayVar(Var *arrayPtr); -static Tcl_Obj * GetArrayDefault(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* @@ -1414,8 +1425,21 @@ TclPtrGetVarIdx( /* * Return the array default value if any. */ - if (arrayPtr && TclIsVarArray(arrayPtr) && GetArrayDefault(arrayPtr)) { - return GetArrayDefault(arrayPtr); + + if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { + return TclGetArrayDefault(arrayPtr); + } + if (TclIsVarArrayElement(varPtr) && !arrayPtr) { + /* + * UGLY! Peek inside the implementation of things. + */ + + ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) + ((VarInHash *) varPtr)->entry.tablePtr; + + if (avhtPtr->defaultObj) { + return avhtPtr->defaultObj; + } } if (flags & TCL_LEAVE_ERR_MSG) { @@ -1809,7 +1833,7 @@ ListAppendInVar( */ if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); if (defValuePtr) { oldValuePtr = Tcl_DuplicateObj(defValuePtr); @@ -1851,7 +1875,7 @@ StringAppendInVar( if (oldValuePtr == NULL) { if (arrayPtr) { - Tcl_Obj *defValuePtr = GetArrayDefault(arrayPtr); + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); if (defValuePtr) { /* @@ -6564,25 +6588,11 @@ CompareVarKeys( return ((l1 == l2) && !memcmp(p1, p2, l1)); } -/* - * TIP #508: [array default] - */ - -/* - * The following structure extends the regular TclVarHashTable used by array - * variables to store their optional default value. - */ - -typedef struct ArrayVarHashTable { - TclVarHashTable table; - Tcl_Obj *defaultObj; -} ArrayVarHashTable; - /*---------------------------------------------------------------------- * * ArrayDefaultCmd -- * - * This function implements the 'array default' Tcl command. + * This function implements the 'array default' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -6639,7 +6649,7 @@ ArrayDefaultCmd( return NotArrayError(interp, arrayNameObj); } - defaultValueObj = GetArrayDefault(varPtr); + defaultValueObj = TclGetArrayDefault(varPtr); if (!defaultValueObj) { /* Array default must exist. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -6660,7 +6670,7 @@ ArrayDefaultCmd( * Attempt to create array if needed. */ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -6669,7 +6679,7 @@ ArrayDefaultCmd( /* * Not a valid array name. */ - + CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", needArray, -1); @@ -6711,7 +6721,7 @@ ArrayDefaultCmd( } else if (!isArray) { return NotArrayError(interp, arrayNameObj); } else { - defaultValueObj = GetArrayDefault(varPtr); + defaultValueObj = TclGetArrayDefault(varPtr); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); } return TCL_OK; @@ -6743,17 +6753,25 @@ void TclInitArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr; + ArrayVarHashTable *tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + /* + * Mark the variable as an array. + */ TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + /* + * Regular TclVarHashTable initialization. + */ - // Regular TclVarHashTable initialization. arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); - // Default value initialization. + /* + * Default value initialization. + */ + tablePtr->defaultObj = NULL; } @@ -6765,14 +6783,20 @@ static void DeleteArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Default value cleanup. + */ - // Default value cleanup. SetArrayDefault(arrayPtr, NULL); - // Regular TclVarHashTable cleanup. - VarHashDeleteTable(arrayPtr->value.tablePtr); + /* + * Regular TclVarHashTable cleanup. + */ + VarHashDeleteTable(arrayPtr->value.tablePtr); ckfree(tablePtr); } @@ -6780,11 +6804,13 @@ DeleteArrayVar( * Get array default value if any. */ -static Tcl_Obj * -GetArrayDefault( +Tcl_Obj * +TclGetArrayDefault( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + return tablePtr->defaultObj; } @@ -6797,16 +6823,18 @@ SetArrayDefault( Var *arrayPtr, Tcl_Obj *defaultObj) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) arrayPtr->value.tablePtr; - + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + /* * Increment/decrement refcount twice to ensure that the object is shared, * so that it doesn't get modified accidentally by the folling code: - * + * * array default set v 1 * lappend v(a) 2; # returns a new object {1 2} * set v(b); # returns the original default object "1" */ + if (tablePtr->defaultObj) { Tcl_DecrRefCount(tablePtr->defaultObj); Tcl_DecrRefCount(tablePtr->defaultObj); diff --git a/tests/set-old.test b/tests/set-old.test index b2e7aa6..ea5155b 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -340,7 +340,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -700,7 +700,7 @@ test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array d a s-3-a; array start a] + [array done a s-2-a; array do a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} -- cgit v0.12 From 9aa47b2cfa64ee148cbc6dace75fbab5a48209b8 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Sep 2018 13:09:20 +0000 Subject: Improved comment. --- generic/tclVar.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 8860df5..cafa6a3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1431,7 +1431,9 @@ TclPtrGetVarIdx( } if (TclIsVarArrayElement(varPtr) && !arrayPtr) { /* - * UGLY! Peek inside the implementation of things. + * UGLY! Peek inside the implementation of things. This lets us get + * the default of an array even when we've been [upvar]ed to just an + * element of the array. */ ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) -- cgit v0.12 From 59f808eb7a065aaf628c751e8eb2c7e20505989b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Sep 2018 19:38:08 +0000 Subject: Improvements for zipfs. Document that TclZipfs_AppHook only works on Windows in UNICODE mode. Also, remove this from the stub table because it should never be called this way. Prevent a possible crash on win32 startup. --- doc/zipfs.3 | 4 +++ generic/tcl.decls | 7 +---- generic/tcl.h | 3 ++ generic/tclDecls.h | 1 + generic/tclPlatDecls.h | 27 ----------------- generic/tclStubInit.c | 7 ----- generic/tclZipfs.c | 80 +++++++++++++++++++++++++------------------------- win/tclAppInit.c | 3 +- 8 files changed, 51 insertions(+), 81 deletions(-) diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 7514525..ce5d5eb 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -47,6 +47,10 @@ If a file named \fBmain.tcl\fR is located in that file system, it is treated as the startup script for the process. If the file \fIZIPROOT\fR\fB/app/tcl_library/init.tcl\fR is present, \fBtcl_library\fR is set to \fIZIPROOT\fR\fB/app/tcl_library. .PP +On Windows, \fBTclZipfs_AppHook()\fR has a slightly different signature, it uses +WCHAR in stead of char. As a result, it only works if your application is compiled +using -DUNICODE. +.PP If the \fBtcl_library\fR was not found in the application, the system will then search for it as either a VFS attached to the application dynamic library, or as a zip archive named libtcl_\fIMAJOR\fR_\fIMINOR\fR_\fIpatchLevel\fR.zip either in the present working directory diff --git a/generic/tcl.decls b/generic/tcl.decls index 92e87d6..61247e6 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2365,9 +2365,6 @@ interface tclPlat ################################ # Unix specific functions # (none) -declare 2 unix { - int TclZipfs_AppHook(int *argc, char ***argv) -} ################################ # Windows specific functions @@ -2380,9 +2377,7 @@ declare 0 win { declare 1 win { char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) } -declare 2 win { - int TclZipfs_AppHook(int *argc, TCHAR ***argv) -} + ################################ # Mac OS X specific functions diff --git a/generic/tcl.h b/generic/tcl.h index b44b9c3..2ced16b 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2402,6 +2402,9 @@ EXTERN void Tcl_MainEx(int argc, char **argv, EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +#ifndef _WIN32 +EXTERN int TclZipfs_AppHook(int *argc, char ***argv); +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0449bf1..3fb5355 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3873,6 +3873,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_MainEx Tcl_MainExW EXTERN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); + EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #endif #undef TCL_STORAGE_CLASS diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index ac3f921..abc8ee8 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,12 +50,6 @@ extern "C" { * Exported function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -/* 2 */ -EXTERN int TclZipfs_AppHook(int *argc, char ***argv); -#endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, @@ -63,8 +57,6 @@ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, /* 1 */ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr); -/* 2 */ -EXTERN int TclZipfs_AppHook(int *argc, TCHAR ***argv); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -77,28 +69,19 @@ EXTERN int Tcl_MacOSXOpenVersionedBundleResources( const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); -/* 2 */ -EXTERN int TclZipfs_AppHook(int *argc, char ***argv); #endif /* MACOSX */ typedef struct TclPlatStubs { int magic; void *hooks; -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*reserved0)(void); - void (*reserved1)(void); - int (*tclZipfs_AppHook) (int *argc, char ***argv); /* 2 */ -#endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ - int (*tclZipfs_AppHook) (int *argc, TCHAR ***argv); /* 2 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ - int (*tclZipfs_AppHook) (int *argc, char ***argv); /* 2 */ #endif /* MACOSX */ } TclPlatStubs; @@ -114,27 +97,17 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -#define TclZipfs_AppHook \ - (tclPlatStubsPtr->tclZipfs_AppHook) /* 2 */ -#endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ -#define TclZipfs_AppHook \ - (tclPlatStubsPtr->tclZipfs_AppHook) /* 2 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_MacOSXOpenBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#define TclZipfs_AppHook \ - (tclPlatStubsPtr->tclZipfs_AppHook) /* 2 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6614764..9fa5adb 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -855,20 +855,13 @@ static const TclIntPlatStubs tclIntPlatStubs = { static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - 0, /* 0 */ - 0, /* 1 */ - TclZipfs_AppHook, /* 2 */ -#endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ - TclZipfs_AppHook, /* 2 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_MacOSXOpenBundleResources, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ - TclZipfs_AppHook, /* 2 */ #endif /* MACOSX */ }; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 55b854b..19673c8 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -18,10 +18,10 @@ #include "tclInt.h" #include "tclFileSystem.h" -#if !defined(_WIN32) && !defined(_WIN64) -#include -#else +#ifdef _WIN32 #include +#else +#include #endif #include #include @@ -142,19 +142,16 @@ * Windows drive letters. */ -#if defined(_WIN32) || defined(_WIN64) -#define HAS_DRIVES 1 +#ifdef _WIN32 static const char drvletters[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -#else -#define HAS_DRIVES 0 #endif /* * Mutex to protect localtime(3) when no reentrant version available. */ -#if !defined(_WIN32) && !defined(_WIN64) +#ifndef _WIN32 #ifndef HAVE_LOCALTIME_R #ifdef TCL_THREADS TCL_DECLARE_MUTEX(localtimeMutex) @@ -173,23 +170,21 @@ typedef struct ZipFile { Tcl_Channel chan; /* Channel handle or NULL */ unsigned char *data; /* Memory mapped or malloc'ed file */ size_t length; /* Length of memory mapped file */ - unsigned char *tofree; /* Non-NULL if malloc'ed file */ + void *tofree; /* Non-NULL if malloc'ed file */ size_t nfiles; /* Number of files in archive */ size_t baseoffs; /* Archive start */ size_t baseoffsp; /* Password start */ size_t centoffs; /* Archive directory start */ unsigned char pwbuf[264]; /* Password buffer */ -#if defined(_WIN32) || defined(_WIN64) - HANDLE mh; -#endif size_t nopen; /* Number of open files on archive */ struct ZipEntry *entries; /* List of files in archive */ struct ZipEntry *topents; /* List of top-level dirs in archive */ -#if HAS_DRIVES - int mntdrv; /* Drive letter of mount point */ -#endif size_t mntptlen; char *mntpt; /* Mount point */ +#ifdef _WIN32 + HANDLE mh; + int mntdrv; /* Drive letter of mount point */ +#endif } ZipFile; /* @@ -516,7 +511,7 @@ ToDosTime(time_t when) struct tm *tmp, tm; #ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 /* Win32 uses thread local storage */ tmp = localtime(&when); tm = *tmp; @@ -544,7 +539,7 @@ ToDosDate(time_t when) struct tm *tmp, tm; #ifdef TCL_THREADS -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 /* Win32 uses thread local storage */ tmp = localtime(&when); tm = *tmp; @@ -621,7 +616,7 @@ CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPA char *path; char *result; int i, j, c, isunc = 0, isvfs=0, n=0; -#if HAS_DRIVES +#ifdef _WIN32 int zipfspath=1; if ( (tail[0] != '\0') @@ -655,7 +650,7 @@ CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPA isunc = 1; } } -#if HAS_DRIVES +#ifdef _WIN32 } #endif if(isvfs!=2) { @@ -707,7 +702,7 @@ CanonicalPath(const char *root, const char *tail, Tcl_DString *dsPtr,int ZIPFSPA memcpy(path + i, tail, j); } } -#if HAS_DRIVES +#ifdef _WIN32 for (i = 0; path[i] != '\0'; i++) { if (path[i] == '\\') { path[i] = '/'; @@ -857,13 +852,13 @@ ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) if(zf->is_membuf==1) { /* Pointer to memory */ if (zf->tofree != NULL) { - Tcl_Free((char *) zf->tofree); + Tcl_Free(zf->tofree); zf->tofree = NULL; } zf->data = NULL; return; } -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 if ((zf->data != NULL) && (zf->tofree == NULL)) { UnmapViewOfFile(zf->data); zf->data = NULL; @@ -878,7 +873,7 @@ ZipFSCloseArchive(Tcl_Interp *interp, ZipFile *zf) } #endif if (zf->tofree != NULL) { - Tcl_Free((char *) zf->tofree); + Tcl_Free(zf->tofree); zf->tofree = NULL; } if(zf->chan != NULL) { @@ -1016,7 +1011,7 @@ ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, ZipFile * ClientData handle; zf->namelen=0; zf->is_membuf=0; -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 zf->data = NULL; zf->mh = INVALID_HANDLE_VALUE; #else @@ -1057,7 +1052,7 @@ ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, ZipFile * Tcl_Close(interp, zf->chan); zf->chan = NULL; } else { -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 # ifdef _WIN64 i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER)&zf->length); if ( @@ -1919,8 +1914,8 @@ ZipAddFile( ZipEntry *z; z_stream stream; const char *zpath; - int crc, flush, zpathlen, olen; - size_t nbyte, nbytecompr, len, align = 0; + int crc, flush, zpathlen; + size_t nbyte, nbytecompr, len, olen, align = 0; Tcl_WideInt pos[3]; int mtime = 0, isNew, cmeth; unsigned long keys[3], keys0[3]; @@ -1944,7 +1939,7 @@ ZipAddFile( || (Tcl_SetChannelOption(interp, in, "-translation", "binary") != TCL_OK) || (Tcl_SetChannelOption(interp, in, "-encoding", "binary") != TCL_OK) ) { -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 /* hopefully a directory */ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { Tcl_Close(interp, in); @@ -2088,13 +2083,14 @@ wrerr: } olen = sizeof (obuf) - stream.avail_out; if (passwd != NULL) { - int i, tmp; + size_t i; + int tmp; for (i = 0; i < olen; i++) { obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); } } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { + if (olen && ((size_t)Tcl_Write(out, obuf, olen) != olen)) { Tcl_AppendResult(interp, "write error", (char *) NULL); deflateEnd(&stream); Tcl_Close(interp, in); @@ -2873,7 +2869,7 @@ ZipFSListObjCmd( return TCL_OK; } -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 #define LIBRARY_SIZE 64 static int ToUtf( @@ -2898,7 +2894,7 @@ Tcl_Obj *TclZipfs_TclLibrary(void) { } else { Tcl_Obj *vfsinitscript; int found=0; -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char dllname[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; @@ -2912,7 +2908,7 @@ Tcl_Obj *TclZipfs_TclLibrary(void) { zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library"; return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); } -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { GetModuleFileNameA(hModule, dllname, MAX_PATH); } else { @@ -4401,12 +4397,15 @@ static int TclZipfs_AppHook_FindTclInit(const char *archive){ return TCL_ERROR; } -#if defined(_WIN32) || defined(_WIN64) +#ifdef _WIN32 int TclZipfs_AppHook(int *argc, TCHAR ***argv) #else int TclZipfs_AppHook(int *argc, char ***argv) #endif { +#ifdef _WIN32 + Tcl_DString ds; +#endif /* * Tclkit_MainHook -- * Performs the argument munging for the shell @@ -4442,14 +4441,13 @@ int TclZipfs_AppHook(int *argc, char ***argv) } } } else if (*argc>1) { -#if defined(_WIN32) || defined(_WIN64) - Tcl_DString ds; - strcpy(archive, Tcl_WinTCharToUtf((*argv)[1], -1, &ds)); - Tcl_DStringFree(&ds); + return TCL_OK; +#ifdef _WIN32 + archive = Tcl_WinTCharToUtf((*argv)[1], -1, &ds); #else archive=(*argv)[1]; #endif - if(strcmp(archive,"install")==0) { + if (strcmp(archive,"install")==0) { /* If the first argument is mkzip, run the mkzip program */ Tcl_Obj *vfsinitscript; /* Run this now to ensure the file is present by the time Tcl_Main wants it */ @@ -4483,10 +4481,12 @@ int TclZipfs_AppHook(int *argc, char ***argv) } } } +#ifdef _WIN32 + Tcl_DStringFree(&ds); +#endif } return TCL_OK; } - #ifndef HAVE_ZLIB diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 6d2bda4..6444b21 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -126,7 +126,8 @@ _tmain( #ifdef TCL_LOCAL_MAIN_HOOK TCL_LOCAL_MAIN_HOOK(&argc, &argv); -#else +#elif !defined(_WIN32) && !defined(UNICODE) + /* This doesn't work on Windows without UNICODE */ TclZipfs_AppHook(&argc, &argv); #endif -- cgit v0.12 From bf46b6a1dac0ded399af13fb18a2cfa7cec8caea Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 27 Sep 2018 07:44:50 +0000 Subject: Updated documentation --- doc/lreplace.n | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/doc/lreplace.n b/doc/lreplace.n index d19f0cd..35a9130 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -30,13 +30,26 @@ list, and \fBend\fR refers to the last element of the list. If \fIlist\fR is empty, then \fIfirst\fR and \fIlast\fR are ignored. .PP If \fIfirst\fR is less than zero, it is considered to refer to before the -first element of the list. For non-empty lists, the element indicated -by \fIfirst\fR must exist or \fIfirst\fR must indicate before the +first element of the list. +.VS TIP505 +If \fIfirst\fR indicates a position greater than the index of the last element +of the list, it is treated as if it is an index one greater than the last +element. This allows this command to append elements to the list. +.VE TIP505 +For non-empty lists, the element indicated +by \fIfirst\fR must exist, or \fIfirst\fR must indicate before the start of the list. .PP If \fIlast\fR is less than \fIfirst\fR, then any specified elements will be inserted into the list before the point specified by \fIfirst\fR with no elements being deleted. +.VS TIP505 +If \fIlast\fR is greater than the index of the last item of the list, it is +treated as if it is an index one greater than the last element. This means +that if it is also greater than than \fIfirst\fR, all elements from +\fIfirst\fR to the end of the list will be replaced, and otherwise the +elements will be appended. +.VE TIP505 .PP The \fIelement\fR arguments specify zero or more new arguments to be added to the list in place of those that were deleted. @@ -78,9 +91,26 @@ proc lremove {listVariable value} { set var [\fBlreplace\fR $var $idx $idx] } .CE +.PP +.VS TIP505 +Adding elements to the end of the list; note that \fBend+2\fR will initially +be treated as if it is \fB6\fR here, but both that and \fB12345\fR are greater +than the index of the final item so they behave identically: +.PP +.CS +% set var {a b c d e} +a b c d e +% set var [\fBlreplace\fR $var 12345 end+2 f g h i] +a b c d e f g h i +.CE +.VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lsort(n), string(n) .SH KEYWORDS element, list, replace +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: -- cgit v0.12