diff --git a/src/_vfscommon/punk1.ico b/src/_vfscommon/punk1.ico new file mode 100644 index 00000000..dac43134 Binary files /dev/null and b/src/_vfscommon/punk1.ico differ diff --git a/src/bootsupport/modules/http-2.10b1.tm b/src/bootsupport/modules/http-2.10b1.tm new file mode 100644 index 00000000..6c3c068c --- /dev/null +++ b/src/bootsupport/modules/http-2.10b1.tm @@ -0,0 +1,5457 @@ +# http.tcl -- +# +# Client-side HTTP for GET, POST, and HEAD commands. These routines can +# be used in untrusted code that uses the Safesock security policy. +# These procedures use a callback interface to avoid using vwait, which +# is not defined in the safe base. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +# Keep this in sync with pkgIndex.tcl and with the install directories in +# Makefiles +package provide http 2.10b1 + +namespace eval http { + # Allow resourcing to not clobber existing data + + variable http + if {![info exists http]} { + array set http { + -accept */* + -cookiejar {} + -pipeline 1 + -postfresh 0 + -proxyhost {} + -proxyport {} + -proxyfilter http::ProxyRequired + -proxynot {} + -proxyauth {} + -repost 0 + -threadlevel 0 + -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 + # 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]} { + set http(-useragent) "Mozilla/5.0\ + (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]" + } + } + + proc init {} { + # Set up the map for quoting chars. RFC3986 Section 2.3 say percent + # encode all except: "... percent-encoded octets in the ranges of + # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period + # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI + # producers ..." + for {set i 0} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + set map($c) %[format %.2X $i] + } + } + # These are handled specially + set map(\n) %0D%0A + variable formMap [array get map] + + # Create a map for HTTP/1.1 open sockets + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + if {[info exists socketMapping]} { + # Close open sockets on re-init. Do not permit retries. + foreach {url sock} [array get socketMapping] { + unset -nocomplain socketClosing($url) + unset -nocomplain socketPlayCmd($url) + CloseSocket $sock + } + } + + # 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 + array unset socketRdQueue + array unset socketWrQueue + array unset socketPhQueue + array unset socketClosing + array unset socketPlayCmd + array unset socketCoEvent + array unset socketProxyId + array set socketMapping {} + array set socketRdState {} + array set socketWrState {} + array set socketRdQueue {} + array set socketWrQueue {} + array set socketPhQueue {} + array set socketClosing {} + array set socketPlayCmd {} + array set socketCoEvent {} + array set socketProxyId {} + return + } + init + + variable urlTypes + if {![info exists urlTypes]} { + set urlTypes(http) [list 80 ::http::socket] + } + + variable encodings [string tolower [encoding names]] + # This can be changed, but iso8859-1 is the RFC standard. + variable defaultCharset + if {![info exists defaultCharset]} { + set defaultCharset "iso8859-1" + } + + # Force RFC 3986 strictness in geturl url verification? + variable strict + if {![info exists strict]} { + set strict 1 + } + + # Let user control default keepalive for compatibility + variable defaultKeepalive + if {![info exists defaultKeepalive]} { + set defaultKeepalive 0 + } + + # Regular expression used to parse cookies + variable CookieRE {(?x) # EXPANDED SYNTAX + \s* # Ignore leading spaces + ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name + = # LITERAL: Equal sign + ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value + (?: + \s* ; \s* # LITERAL: semicolon + ([^\u0000]+) # Match the options + )? + } + + variable TmpSockCounter 0 + variable ThreadCounter 0 + + variable reasonDict [dict create {*}{ + 100 Continue + 101 {Switching Protocols} + 102 Processing + 103 {Early Hints} + 200 OK + 201 Created + 202 Accepted + 203 {Non-Authoritative Information} + 204 {No Content} + 205 {Reset Content} + 206 {Partial Content} + 207 Multi-Status + 208 {Already Reported} + 226 {IM Used} + 300 {Multiple Choices} + 301 {Moved Permanently} + 302 Found + 303 {See Other} + 304 {Not Modified} + 305 {Use Proxy} + 306 (Unused) + 307 {Temporary Redirect} + 308 {Permanent Redirect} + 400 {Bad Request} + 401 Unauthorized + 402 {Payment Required} + 403 Forbidden + 404 {Not Found} + 405 {Method Not Allowed} + 406 {Not Acceptable} + 407 {Proxy Authentication Required} + 408 {Request Timeout} + 409 Conflict + 410 Gone + 411 {Length Required} + 412 {Precondition Failed} + 413 {Content Too Large} + 414 {URI Too Long} + 415 {Unsupported Media Type} + 416 {Range Not Satisfiable} + 417 {Expectation Failed} + 418 (Unused) + 421 {Misdirected Request} + 422 {Unprocessable Content} + 423 Locked + 424 {Failed Dependency} + 425 {Too Early} + 426 {Upgrade Required} + 428 {Precondition Required} + 429 {Too Many Requests} + 431 {Request Header Fields Too Large} + 451 {Unavailable For Legal Reasons} + 500 {Internal Server Error} + 501 {Not Implemented} + 502 {Bad Gateway} + 503 {Service Unavailable} + 504 {Gateway Timeout} + 505 {HTTP Version Not Supported} + 506 {Variant Also Negotiates} + 507 {Insufficient Storage} + 508 {Loop Detected} + 510 {Not Extended (OBSOLETED)} + 511 {Network Authentication Required} + }] + + variable failedProxyValues { + binary + body + charset + coding + connection + connectionRespFlag + currentsize + host + http + httpResponse + meta + method + querylength + queryoffset + reasonPhrase + requestHeaders + requestLine + responseCode + state + status + tid + totalsize + transfer + type + } + + namespace export geturl config reset wait formatQuery postError quoteString + namespace export register unregister registerError + namespace export requestLine requestHeaders requestHeaderValue + namespace export responseLine responseHeaders responseHeaderValue + namespace export responseCode responseBody responseInfo reasonPhrase + # - Legacy aliases, were never exported: + # data, code, mapReply, meta, ncode + # - Callable from outside (e.g. from TLS) by fully-qualified name, but + # not exported: + # socket + # - Useful, but never exported (and likely to have naming collisions): + # size, status, cleanup, error, init + # Comments suggest that "init" can be used for re-initialisation, + # although the command is undocumented. + # - Never exported, renamed from lower-case names: + # GetTextLine, MakeTransformationChunked. +} + +# http::Log -- +# +# Debugging output -- define this to observe HTTP/1.1 socket usage. +# Should echo any args received. +# +# Arguments: +# msg Message to output +# +if {[info command http::Log] eq {}} {proc http::Log {args} {}} + +# http::register -- +# +# See documentation for details. +# +# Arguments: +# proto URL protocol prefix, e.g. https +# port Default port for protocol +# command Command to use to create socket +# Results: +# list of port and command that was registered. + +proc http::register {proto port command} { + variable urlTypes + set urlTypes([string tolower $proto]) [list $port $command] +} + +# http::unregister -- +# +# Unregisters URL protocol handler +# +# Arguments: +# proto URL protocol prefix, e.g. https +# Results: +# list of port and command that was unregistered. + +proc http::unregister {proto} { + variable urlTypes + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + return -code error "unsupported url type \"$proto\"" + } + set old $urlTypes($lower) + unset urlTypes($lower) + return $old +} + +# http::config -- +# +# See documentation for details. +# +# Arguments: +# args Options parsed by the procedure. +# Results: +# TODO + +proc http::config {args} { + variable http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + return $http($flag) + } elseif {[llength $args] % 2} { + return -code error "If more than one argument is supplied, the\ + number of arguments must be even" + } else { + foreach {flag value} $args { + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} { + return -code error {Option -threadlevel must be 0, 1 or 2} + } + set http($flag) $value + } + return + } +} + +# ------------------------------------------------------------------------------ +# Proc http::reasonPhrase +# ------------------------------------------------------------------------------ +# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code. +# Information obtained from: +# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml +# +# Arguments: +# code - A valid HTTP Status Code (integer from 100 to 599) +# +# Return Value: the reason phrase +# ------------------------------------------------------------------------------ + +proc http::reasonPhrase {code} { + variable reasonDict + if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { + set msg {argument must be a three-digit integer from 100 to 599} + return -code error $msg + } + if {[dict exists $reasonDict $code]} { + set reason [dict get $reasonDict $code] + } else { + set reason Unassigned + } + return $reason +} + +# http::Finish -- +# +# Clean up the socket and eval close time callbacks +# +# Arguments: +# token Connection token. +# errormsg (optional) If set, forces status to error. +# 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. +# +# Side Effects: +# May close the socket. + +proc http::Finish {token {errormsg ""} {skipCB 0}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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" + } + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) + } + + # Is this an upgrade request/response? + set upgradeResponse \ + [expr { [info exists state(upgradeRequest)] + && $state(upgradeRequest) + && [info exists state(http)] + && ([ncode $token] eq {101}) + && [info exists state(connection)] + && ("upgrade" in $state(connection)) + && [info exists state(upgrade)] + && ("" ne $state(upgrade)) + }] + + if { ($state(status) eq "timeout") + || ($state(status) eq "error") + || ($state(status) eq "eof") + } { + set closeQueue 1 + set connId $state(socketinfo) + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } + if {$state(tid) ne {}} { + # When opening the socket in a thread, and calling http::reset + # immediately, the thread may still exist. + # Test http-4.11 may come here. + thread::release $state(tid) + set state(tid) {} + } else { + } + } elseif {$upgradeResponse} { + # Special handling for an upgrade request/response. + # - geturl ensures that this is not a "persistent" socket used for + # multiple HTTP requests, so a call to KeepSocket is not needed. + # - Leave socket open, so a call to CloseSocket is not needed either. + # - Remove fileevent bindings. The caller will set its own bindings. + # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND + # PASSED TO http::geturl AS -command callback. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + } elseif { + ([info exists state(-keepalive)] && !$state(-keepalive)) + || ([info exists state(connection)] && ("close" in $state(connection))) + } { + set closeQueue 1 + set connId $state(socketinfo) + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } + } elseif { + ([info exists state(-keepalive)] && $state(-keepalive)) + && ([info exists state(connection)] && ("close" ni $state(connection))) + } { + KeepSocket $token + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state(-command)] && (!$skipCB) + && (![info exists state(done-command-cb)])} { + set state(done-command-cb) yes + if { [catch {namespace eval :: $state(-command) $token} err] + && ($errormsg eq "") + } { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + + if { $closeQueue + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $sock) + } { + http::CloseQueuedQueries $connId $token + # This calls Unset. Other cases do not need the call. + } + 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. +# +# If $socketClosing(*), then ("close" in $state(connection)) and therefore +# this command will not be called by Finish. +# +# Arguments: +# token Connection token. + +proc http::KeepSocket {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 {}} + } + + 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] + + #Log pipelined, GRANT read access to $token3 in KeepSocket + set socketRdState($connId) $token3 + ReceiveResponse $token3 + + # 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. + set conn [set ${token3}(connArgs)] + #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. + set conn [set ${token3}(connArgs)] + #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)] + && ("close" ni $state(connection)) + } { + # 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] + set conn [set ${token3}(connArgs)] + #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 { + CloseSocket $state(sock) $token + # There is no socketMapping($state(socketinfo)), so it does not matter + # that CloseQueuedQueries is not called. + } + 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 +} + +# http::CloseSocket - +# +# 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 "else" block of the first "if" command. + +proc http::CloseSocket {s {token {}}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set tk [namespace tail $token] + + catch {fileevent $s readable {}} + set connId {} + if {$token ne ""} { + variable $token + upvar 0 $token state + if {[info exists state(socketinfo)]} { + set connId $state(socketinfo) + } + } else { + set map [array get socketMapping] + set ndx [lsearch -exact $map $s] + if {$ndx >= 0} { + incr ndx -1 + set connId [lindex $map $ndx] + } + } + 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 + } 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 socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + ##Log CloseQueuedQueries $connId $token + 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 { + set tk [namespace tail $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". + # - At this stage socketPhQueue is empty. + set unfinished $socketPlayCmd($connId) + set socketRdQueue($connId) {} + set socketWrQueue($connId) {} + } else { + set unfinished {} + } + + Unset $connId + + if {$unfinished ne {}} { + Log ^R$tk Any unfinished transactions (excluding $token) failed \ + - token $token - unfinished $unfinished + {*}$unfinished + # Calls ReplayIfClose. + } + 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 socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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) + unset -nocomplain socketProxyId($connId) + return +} + +# http::reset -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# why Status info. +# +# Side Effects: +# See Finish + +proc http::reset {token {why reset}} { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state + eval ::error $errorlist + # i.e. error msg errorInfo errorCode + } + return +} + +# http::geturl -- +# +# Establishes a connection to a remote url via http. +# +# Arguments: +# 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 +# array that the caller should unset to garbage collect the state. + +proc http::geturl {url args} { + variable urlTypes + + # - If ::tls::socketCmd has its default value "::socket", change it to the + # new value ::http::socketForTls. + # - If the old value is different, then it has been modified either by the + # script or by the Tcl installation, and replaced by a new command. The + # script or installation that modified ::tls::socketCmd is also + # responsible for integrating ::http::socketForTls into its own "new" + # command, if it wishes to do so. + # - Commands that open a socket: + # - ::socket - basic + # - ::http::socket - can use a thread to avoid blockage by slow DNS + # lookup. See http::config option -threadlevel. + # - ::http::socketForTls - as ::http::socket, but can also open a socket + # for HTTPS/TLS through a proxy. + + if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} { + set ::tls::socketCmd ::http::socketForTls + } + + set token [CreateToken $url {*}$args] + variable $token + upvar 0 $token state + + AsyncTransaction $token + + # -------------------------------------------------------------------------- + # Synchronous Call to http::geturl + # -------------------------------------------------------------------------- + # - If the call to http::geturl is asynchronous, it is now complete (apart + # from delivering the return value). + # - If the call to http::geturl is synchronous, the command must now wait + # for the HTTP transaction to be completed. The call to http::wait uses + # vwait, which may be inappropriate if the caller makes other HTTP + # requests in the background. + # -------------------------------------------------------------------------- + + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. + http::wait $token + + if {![info exists state]} { + # If we timed out then Finish has been called and the users + # command callback may have cleaned up the token. If so we end up + # here with nothing left to do. + return $token + } elseif {$state(status) eq "error"} { + # 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. + set err [lindex $state(error) 0] + cleanup $token + return -code error $err + } + } + + return $token +} + +# ------------------------------------------------------------------------------ +# Proc http::CreateToken +# ------------------------------------------------------------------------------ +# Command to convert arguments into an initialised request token. +# The return value is the variable name of the token. +# +# Other effects: +# - Sets ::http::http(usingThread) if not already done +# - Sets ::http::http(uid) if not already done +# - Increments ::http::http(uid) +# - May increment ::http::TmpSockCounter +# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1 +# request is appended to the queue of a persistent socket that is already +# scheduled to close. +# This also sets state(alreadyQueued) to 1. +# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the +# queue of a persistent socket that has not yet been created (and is therefore +# represented by a placeholder). +# This also sets state(ReusingPlaceholder) to 1. +# ------------------------------------------------------------------------------ + +proc http::CreateToken {url args} { + variable http + variable urlTypes + variable defaultCharset + variable defaultKeepalive + variable strict + variable TmpSockCounter + + # Initialize the state variable, an array. We'll return the name of this + # array as the token for the transaction. + + if {![info exists http(usingThread)]} { + set http(usingThread) 0 + } + if {![info exists http(uid)]} { + 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. + + array set state { + -binary false + -blocksize 8192 + -queryblocksize 8192 + -validate 0 + -headers {} + -timeout 0 + -type application/x-www-form-urlencoded + -queryprogress {} + -protocol 1.1 + -guesstype 0 + binary 0 + state created + meta {} + method {} + coding {} + currentsize 0 + totalsize 0 + querylength 0 + queryoffset 0 + type application/octet-stream + body {} + status "" + http "" + httpResponse {} + responseCode {} + reasonPhrase {} + connection keep-alive + tid {} + requestHeaders {} + requestLine {} + transfer {} + proxyUsed none + } + set state(-keepalive) $defaultKeepalive + set state(-strict) $strict + # These flags have their types verified [Bug 811170] + array set type { + -binary boolean + -blocksize integer + -guesstype boolean + -queryblocksize integer + -strict boolean + -timeout integer + -validate boolean + -headers list + } + set state(charset) $defaultCharset + set options { + -binary -blocksize -channel -command -guesstype -handler -headers -keepalive + -method -myaddr -progress -protocol -query -queryblocksize + -querychannel -queryprogress -strict -timeout -type -validate + } + set usage [join [lsort $options] ", "] + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + foreach {flag value} $args { + if {[regexp -- $pat $flag]} { + # Validate numbers + if { [info exists type($flag)] + && (![string is $type($flag) -strict $value]) + } { + unset $token + return -code error \ + "Bad value for $flag ($value), must be $type($flag)" + } + if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { + unset $token + return -code error "Bad value for $flag ($value), number\ + of list elements must be even" + } + set state($flag) $value + } else { + unset $token + return -code error "Unknown option $flag, can be: $usage" + } + } + + # Make sure -query and -querychannel aren't both specified + + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {$isQuery && $isQueryChannel} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Validate URL, determine the server host and port, and check proxy case + # Recognize user:pass@host URLs also, although we do not do anything with + # that info yet. + + # URLs have basically four parts. + # First, before the colon, is the protocol scheme (e.g. http) + # Second, for HTTP-like protocols, is the authority + # The authority is preceded by // and lasts up to (but not including) + # the following / or ? and it identifies up to four parts, of which + # only one, the host, is required (if an authority is present at all). + # All other parts of the authority (user name, password, port number) + # are optional. + # Third is the resource name, which is split into two parts at a ? + # The first part (from the single "/" up to "?") is the path, and the + # second part (from that "?" up to "#") is the query. *HOWEVER*, we do + # not need to separate them; we send the whole lot to the server. + # Both, path and query are allowed to be missing, including their + # delimiting character. + # Fourth is the fragment identifier, which is everything after the first + # "#" in the URL. The fragment identifier MUST NOT be sent to the server + # and indeed, we don't bother to validate it (it could be an error to + # pass it in here, but it's cheap to strip). + # + # An example of a URL that has all the parts: + # + # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes + # + # The "http" is the protocol, the user is "jschmoe", the password is + # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is + # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". + # + # Note that the RE actually combines the user and password parts, as + # recommended in RFC 3986. Indeed, that RFC states that putting passwords + # in URLs is a Really Bad Idea, something with which I would agree utterly. + # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format + # "user:password@". It is retained here for backward compatibility, + # but its use is not recommended. + # + # From a validation perspective, we need to ensure that the parts of the + # URL that are going to the server are correctly encoded. This is only + # done if $state(-strict) is true (inherited from $::http::strict). + + set URLmatcher {(?x) # this is _expanded_ syntax + ^ + (?: (\w+) : ) ? # + (?: // + (?: + ( + [^@/\#?]+ # + ) @ + )? + ( # + [^/:\#?]+ | # host name or IPv4 address + \[ [^/\#?]+ \] # IPv6 address in square brackets + ) + (?: : (\d+) )? # + )? + ( [/\?] [^\#]*)? # (including query) + (?: \# (.*) )? # + $ + } + + # Phase one: parse + if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { + unset $token + return -code error "Unsupported URL: $url" + } + # Phase two: validate + set host [string trim $host {[]}]; # strip square brackets from IPv6 address + if {$host eq ""} { + # Caller has to provide a host name; we do not have a "default host" + # that would enable us to handle relative URLs. + unset $token + return -code error "Missing host part: $url" + # Note that we don't check the hostname for validity here; if it's + # invalid, we'll simply fail to resolve it later on. + } + if {$port ne "" && $port > 65535} { + unset $token + return -code error "Invalid port number: $port" + } + # The user identification and resource identification parts of the URL can + # have encoded characters in them; take care! + if {$user ne ""} { + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ + $ + } + if {$state(-strict) && ![regexp -- $validityRE $user]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL user" + } + return -code error "Illegal characters in URL user" + } + } + if {$srvurl ne ""} { + # RFC 3986 allows empty paths (not even a /), but servers + # return 400 if the path in the HTTP request doesn't start + # with / , so add it here if needed. + if {[string index $srvurl 0] ne "/"} { + set srvurl /$srvurl + } + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + # Path part (already must start with / character) + (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* + # Query part (optional, permits ? characters) + (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? + $ + } + if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL path" + } + return -code error "Illegal characters in URL path" + } + if {![regexp {^[^?#]+} $srvurl state(path)]} { + set state(path) / + } + } else { + set srvurl / + set state(path) / + } + if {$proto eq ""} { + set proto http + } + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + unset $token + return -code error "Unsupported URL type \"$proto\"" + } + set defport [lindex $urlTypes($lower) 0] + set defcmd [lindex $urlTypes($lower) 1] + + if {$port eq ""} { + set port $defport + } + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } else { + set phost {} + set pport {} + } + + # OK, now reassemble into a full URL + set url ${proto}:// + if {$user ne ""} { + append url $user + append url @ + } + append url $host + if {$port != $defport} { + append url : $port + } + append url $srvurl + # Don't append the fragment! RFC 7230 Sec 5.1 + set state(url) $url + + # Proxy connections aren't shared among different hosts. + set state(socketinfo) $host:$port + + # Save the accept types at this point to prevent a race condition. [Bug + # c11a51c482] + set state(accept-types) $http(-accept) + + # Check whether this is an Upgrade request. + set connectionValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Connection]] + set connectionValues [string tolower $connectionValues] + set upgradeValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Upgrade]] + set state(upgradeRequest) [expr { "upgrade" in $connectionValues + && [llength $upgradeValues] >= 1}] + set state(connectionValues) $connectionValues + + 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 + } + } elseif {$state(upgradeRequest)} { + # It's an upgrade request. Method must be GET (untested). + # Force -keepalive to 0 so the connection is not made over a persistent + # socket, i.e. one used for multiple HTTP requests. + set state(-keepalive) 0 + } else { + # It's a non-upgrade GET or HEAD. + set state(-pipeline) $http(-pipeline) + } + + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } + + # Handle proxy requests here for http:// but not for https:// + # The proxying for https is done in the ::http::socketForTls command. + # A proxy request for http:// needs the full URL in the HTTP request line, + # including the server name. + # The *tls* test below attempts to describe protocols in addition to + # "https on port 443" that use HTTP over TLS. + if {($phost ne "") && (![string match -nocase *tls* $defcmd])} { + set srvurl $url + set targetAddr [list $phost $pport] + set state(proxyUsed) HttpProxy + # The value of state(proxyUsed) none|HttpProxy depends only on the + # all-transactions http::config settings and on the target URL. + # Even if this is a persistent socket there is no need to change the + # value of state(proxyUsed) for other transactions that use the socket: + # they have the same value already. + } else { + set targetAddr [list $host $port] + } + + set sockopts [list -async] + + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + + set state(connArgs) [list $proto $phost $srvurl] + set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr] + + # 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 state(alreadyQueued) 0 + set state(ReusingPlaceholder) 0 + if {$state(-keepalive)} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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. + + if { [info exists socketClosing($state(socketinfo))] + && $socketClosing($state(socketinfo)) + } { + # 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)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) + Log "reusing closing socket $sock for $state(socketinfo) - token $token" + + set state(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 + ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo)) + ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo)) + } elseif { + [catch {fconfigure $socketMapping($state(socketinfo))}] + && (![SockIsPlaceHolder $socketMapping($state(socketinfo))]) + } { + ###Log "Socket $socketMapping($state(socketinfo)) for $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 + # 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. + # - The socket may not yet exist, and be defined with a placeholder. + set reusing 1 + set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) + if {[SockIsPlaceHolder $sock]} { + set state(ReusingPlaceholder) 1 + lappend socketPhQueue($sock) $token + } else { + } + Log "reusing open socket $sock for $state(socketinfo) - token $token" + } + # Do not automatically close the connection socket. + set state(connection) keep-alive + } + } + + set state(reusing) $reusing + unset reusing + + if {![info exists sock]} { + # N.B. At this point ([info exists sock] == $state(reusing)). + # This will no longer be true after we set a value of sock here. + # Give the socket a placeholder name. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + } + set state(sock) $sock + + if {$state(reusing)} { + # Define these for use (only) by http::ReplayIfDead if the persistent + # connection has died. + set state(tmpConnArgs) $state(connArgs) + set state(tmpState) [array get state] + set state(tmpOpenCmd) $state(openCmd) + } + return $token +} + + +# ------------------------------------------------------------------------------ +# Proc ::http::SockIsPlaceHolder +# ------------------------------------------------------------------------------ +# Command to return 0 if the argument is a genuine socket handle, or 1 if is a +# placeholder value generated by geturl or ReplayCore before the real socket is +# created. +# +# Arguments: +# sock - either a valid socket handle or a placeholder value +# +# Return Value: 0 or 1 +# ------------------------------------------------------------------------------ + +proc http::SockIsPlaceHolder {sock} { + expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}} +} + + +# ------------------------------------------------------------------------------ +# state(reusing) +# ------------------------------------------------------------------------------ +# - state(reusing) is set by geturl, ReplayCore +# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket, +# ConfigureNewSocket, and ScheduleRequest when creating and configuring the +# connection. +# - state(reusing) is used by Connect, Connected, Event x 2 when deciding +# whether to call TestForReplay. +# - Other places 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. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::AsyncTransaction +# ------------------------------------------------------------------------------ +# This command is called by geturl and ReplayCore to prepare the HTTP +# transaction prescribed by a suitably prepared token. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::AsyncTransaction {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set sock $state(sock) + + # 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 { $state(-keepalive) + && (![info exists socketMapping($state(socketinfo))]) + } { + # This code is executed only for the first -keepalive request on a + # socket. It makes the socket persistent. + ##Log " PreparePersistentConnection" $token -- $sock -- DO + set DoLater [PreparePersistentConnection $token] + } else { + ##Log " PreparePersistentConnection" $token -- $sock -- SKIP + set DoLater {-traceread 0 -tracewrite 0} + } + + if {$state(ReusingPlaceholder)} { + # - This request was added to the socketPhQueue of a persistent + # connection. + # - But the connection has not yet been created and is a placeholder; + # - And the placeholder was created by an earlier request. + # - When that earlier request calls OpenSocket, its placeholder is + # replaced with a true socket, and it then executes the equivalent of + # OpenSocket for any subsequent requests that have + # $state(ReusingPlaceholder). + Log >J$tk after idle coro NO - ReusingPlaceholder + } elseif {$state(alreadyQueued)} { + # - This request was added to the socketWrQueue and socketPlayCmd + # of a persistent connection that will close at the end of its current + # read operation. + Log >J$tk after idle coro NO - alreadyQueued + } else { + Log >J$tk after idle coro YES + set CoroName ${token}--SocketCoroutine + set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ + $token $DoLater]] + dict set socketCoEvent($state(socketinfo)) $token $cancel + set state(socketcoro) $cancel + } + + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::PreparePersistentConnection +# ------------------------------------------------------------------------------ +# This command is called by AsyncTransaction to initialise a "persistent +# connection" based upon a socket placeholder. It is called the first time the +# socket is associated with a "-keepalive" request. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: - DoLater, a dictionary of boolean values listing unfinished +# tasks; to be passed to ConfigureNewSocket via OpenSocket. +# ------------------------------------------------------------------------------ + +proc http::PreparePersistentConnection {token} { + variable $token + upvar 0 $token state + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set DoLater {-traceread 0 -tracewrite 0} + set socketMapping($state(socketinfo)) $state(sock) + set socketProxyId($state(socketinfo)) $state(proxyUsed) + # - The value of state(proxyUsed) was set in http::CreateToken to either + # "none" or "HttpProxy". + # - $token is the first transaction to use this placeholder, so there are + # no other tokens whose (proxyUsed) must be modified. + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + # set varName ::http::socketRdState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelReadPipeline + dict set DoLater -traceread 1 + } + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + # set varName ::http::socketWrState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelWritePipeline + dict set DoLater -tracewrite 1 + } + + 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 + } + + # Value of socketPhQueue() may have already been set by ReplayCore. + if {![info exists socketPhQueue($state(sock))]} { + set socketPhQueue($state(sock)) {} + } + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + set socketCoEvent($state(socketinfo)) {} + set socketProxyId($state(socketinfo)) {} + + return $DoLater +} + +# ------------------------------------------------------------------------------ +# Proc ::http::OpenSocket +# ------------------------------------------------------------------------------ +# This command is called as a coroutine idletask to start the asynchronous HTTP +# transaction in most cases. For the exceptions, see the calling code in +# command AsyncTransaction. +# +# Arguments: +# token - connection token (name of an array) +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::OpenSocket {token DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + Log >K$tk Start OpenSocket coroutine + + if {![info exists state(-keepalive)]} { + # The request has already been cancelled by the calling script. + return + } + + set sockOld $state(sock) + + dict unset socketCoEvent($state(socketinfo)) $token + unset -nocomplain state(socketcoro) + + if {[catch { + if {$state(reusing)} { + # If ($state(reusing)) is true, then we do not need to create a new + # socket, even if $sockOld is only a placeholder for a socket. + set sock $sockOld + } else { + # set sock in the [catch] below. + set pre [clock milliseconds] + ##Log pre socket opened, - token $token + ##Log $state(openCmd) - token $token + set sock [namespace eval :: $state(openCmd)] + set state(sock) $sock + # Normal return from $state(openCmd) always returns a valid socket. + # A TLS proxy connection with 407 or other failure from the + # proxy server raises an error. + + # Initialisation of a new socket. + ##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) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + ##Log socket opened, DONE fconfigure - token $token + } + + Log "Using $sock for $state(socketinfo) - token $token" \ + [expr {$state(-keepalive)?"keepalive":""}] + + # Code above has set state(sock) $sock + ConfigureNewSocket $token $sockOld $DoLater + ##Log OpenSocket success $sock - token $token + } result errdict]} { + ##Log OpenSocket failed $result - token $token + # There may be other requests in the socketPhQueue. + # Prepare socketPlayCmd so that Finish will replay them. + if { ($state(-keepalive)) && (!$state(reusing)) + && [info exists socketPhQueue($sockOld)] + && ($socketPhQueue($sockOld) ne {}) + } { + if {$socketMapping($state(socketinfo)) ne $sockOld} { + Log "WARNING: this code should not be reached.\ + {$socketMapping($state(socketinfo)) ne $sockOld}" + } + set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] + set socketPhQueue($sockOld) {} + } + if {[string range $result 0 20] eq {proxy connect failed:}} { + # - The HTTPS proxy did not create a socket. The pre-existing value + # (a "placeholder socket") is unchanged. + # - The proxy returned a valid HTTP response to the failed CONNECT + # request, and http::SecureProxyConnect copied this to $token, + # and also set ${token}(connection) set to "close". + # - Remove the error message $result so that Finish delivers this + # HTTP response to the caller. + set result {} + } + Finish $token $result + # Because socket creation failed, the placeholder "socket" must be + # "closed" and (if persistent) removed from the persistent sockets + # table. In the {proxy connect failed:} case Finish does this because + # the value of ${token}(connection) is "close". In the other cases here, + # it does so because $result is non-empty. + } + ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token + return +} + + +# ------------------------------------------------------------------------------ +# Proc ::http::ConfigureNewSocket +# ------------------------------------------------------------------------------ +# Command to initialise a newly-created socket. Called only from OpenSocket. +# +# This command is called by OpenSocket whenever a genuine socket (sockNew) has +# been opened for for use by HTTP. It does two things: +# (1) If $token uses a placeholder socket, this command replaces the placeholder +# socket with the real socket, not only in $token but in all other requests +# that use the same placeholder. +# (2) It calls ScheduleRequest to schedule each request that uses the socket. +# +# +# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder). +# sockNew is ${token}(sock) +# sockOld sockNew CASES +# sock sock (if $reusing, and sockOld is sock) +# ph sock (if (not $reusing), and sockOld is ph) +# ph ph (if $reusing, and sockOld is ph) - not called in this case +# sock ph (cannot occur unless a bug) - not called in this case +# (if (not $reusing), and sockOld is sock) - illogical +# +# Arguments: +# token - connection token (name of an array) +# sockOld - handle or placeholder used for a socket before the call to +# OpenSocket +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::ConfigureNewSocket {token sockOld DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set reusing $state(reusing) + set sock $state(sock) + set proxyUsed $state(proxyUsed) + ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed + + if {(!$reusing) && ($sock ne $sockOld)} { + # Replace the placeholder value sockOld with sock. + + if { [info exists socketMapping($state(socketinfo))] + && ($socketMapping($state(socketinfo)) eq $sockOld) + } { + set socketMapping($state(socketinfo)) $sock + set socketProxyId($state(socketinfo)) $proxyUsed + # tokens that use the placeholder $sockOld are updated below. + ##Log set socketMapping($state(socketinfo)) $sock + } + + # Now finish any tasks left over from PreparePersistentConnection on + # the connection. + # + # The "unset" traces are fired by init (clears entire arrays), and + # by http::Unset. + # Unset is called by CloseQueuedQueries and (possibly never) by geturl. + # + # CancelReadPipeline, CancelWritePipeline call http::Finish for each + # token. + # + # FIXME If Finish is placeholder-aware, these traces can be set earlier, + # in PreparePersistentConnection. + + if {[dict get $DoLater -traceread]} { + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + if {[dict get $DoLater -tracewrite]} { + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + } + + # Do this in all cases. + ScheduleRequest $token + + # Now look at all other tokens that use the placeholder $sockOld. + if { (!$reusing) + && ($sock ne $sockOld) + && [info exists socketPhQueue($sockOld)] + } { + ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) + foreach tok $socketPhQueue($sockOld) { + # 1. Amend the token's (sock). + ##Log set ${tok}(sock) $sock + set ${tok}(sock) $sock + set ${tok}(proxyUsed) $proxyUsed + + # 2. Schedule the token's HTTP request. + # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. + set ${tok}(reusing) 1 + set ${tok}(alreadyQueued) 0 + ScheduleRequest $tok + } + set socketPhQueue($sockOld) {} + } + ##Log " ConfigureNewSocket" $token DONE + + return +} + + +# ------------------------------------------------------------------------------ +# The values of array variables socketMapping etc. +# ------------------------------------------------------------------------------ +# connId "$host:$port" +# socketMapping($connId) the handle or placeholder for the socket that is used +# for "-keepalive 1" requests to $connId. +# socketRdState($connId) the token that is currently reading from the socket. +# Other values: Rready (ready for next token to read). +# socketWrState($connId) the token that is currently writing to the socket. +# Other values: Wready (ready for next token to write), +# peNding (would be ready for next write, except that +# the integrity of a non-pipelined transaction requires +# waiting until the read(s) in progress are finished). +# socketRdQueue($connId) List of tokens that are queued for reading later. +# socketWrQueue($connId) List of tokens that are queued for writing later. +# socketPhQueue($sock) List of tokens that are queued to use a placeholder +# socket, when the real socket has not yet been created. +# socketClosing($connId) (boolean) true iff a server response header indicates +# that the server will close the connection at the end of +# the current response. +# socketPlayCmd($connId) The command to execute to replay pending and +# part-completed transactions if the socket closes early. +# socketCoEvent($connId) Identifier for the "after idle" event that will launch +# an OpenSocket coroutine to open or re-use a socket. +# socketProxyId($connId) The type of proxy that this socket uses: values are +# those of state(proxyUsed) i.e. none, HttpProxy, +# SecureProxy, and SecureProxyFailed. +# The value is not used for anything by http, its purpose +# is to set the value of state() for caller information. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*) +# ------------------------------------------------------------------------------ +# 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. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::ScheduleRequest +# ------------------------------------------------------------------------------ +# Command to either begin the HTTP request, or add it to the appropriate queue. +# Called from two places in ConfigureNewSocket. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::ScheduleRequest {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + Log >L$tk ScheduleRequest + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set Unfinished 0 + + set reusing $state(reusing) + set sockNew $state(sock) + + # The "if" tests below: must test against the current values of + # socketWrState, socketRdState, and so the tests must be done here, + # not earlier in PreparePersistentConnection. + + if {$state(alreadyQueued)} { + # The request has been appended to the queue of a persistent socket + # (that is scheduled to close and have its queue replayed). + # + # 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 new, init for pipelined, GRANT write access to $token in geturl + # DO NOT grant premature read access to the socket. + # set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } elseif {$reusing} { + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + } + + # Process the request now. + # - Command is not called unless $state(sock) is a real socket handle + # and not a placeholder. + # - All (!$reusing) cases come here. + # - Some $reusing cases come here too if the connection is + # marked as ready. Those $reusing cases are: + # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && + # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") + # OR $pipeline + # + #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token + # Connect does its own fconfigure. + + lassign $state(connArgs) proto phost srvurl + + if {[catch { + fileevent $state(sock) writable \ + [list http::Connect $token $proto $phost $srvurl] + } res opts]} { + # The socket no longer exists. + ##Log bug -- socket gone -- $res -- $opts + } + + } + + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::SendHeader +# ------------------------------------------------------------------------------ +# Command to send a request header, and keep a copy in state(requestHeaders) +# for debugging purposes. +# +# Arguments: +# token - connection token (name of an array) +# key - header name +# value - header value +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::SendHeader {token key value} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + lappend state(requestHeaders) [string tolower $key] $value + puts $sock "$key: $value" + return +} + +# http::Connected -- +# +# Callback used when the connection to the HTTP server is actually +# established. +# +# Arguments: +# 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: +# None. + +proc http::Connected {token proto phost srvurl} { + variable http + variable urlTypes + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + 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)] + set isQuery [info exists state(-query)] + regexp {^(.+):([^:]+)$} $state(socketinfo) {} host port + + set lower [string tolower $proto] + set defport [lindex $urlTypes($lower) 0] + + # Send data in cr-lf format, but accept any line terminators. + # 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] \ + -buffersize $state(-blocksize) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + + # The following is disallowed in safe interpreters, but the socket is + # already in non-blocking mode in that case. + + catch {fconfigure $sock -blocking off} + set how GET + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { + set how POST + set contDone 0 + } else { + # There's no query data. + unset state(-query) + set isQuery 0 + } + } elseif {$state(-validate)} { + set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 -translation binary + set contDone 0 + } + if {[info exists state(-method)] && ($state(-method) ne "")} { + set how $state(-method) + } + set accept_types_seen 0 + + Log ^B$tk begin sending request - token $token + + if {[catch { + if {[info exists state(bypass)]} { + set state(method) [lindex [split $state(bypass) { }] 0] + set state(requestHeaders) {} + set state(requestLine) $state(bypass) + } else { + set state(method) $how + set state(requestHeaders) {} + set state(requestLine) "$how $srvurl HTTP/$state(-protocol)" + } + puts $sock $state(requestLine) + set hostValue [GetFieldValue $state(-headers) Host] + if {$hostValue ne {}} { + # Allow Host spoofing. [Bug 928154] + regexp {^[^:]+} $hostValue state(host) + SendHeader $token Host $hostValue + } elseif {$port == $defport} { + # Don't add port in this case, to handle broken servers. [Bug + # #504508] + set state(host) $host + SendHeader $token Host $host + } else { + set state(host) $host + SendHeader $token Host "$host:$port" + } + SendHeader $token User-Agent $http(-useragent) + if {($state(-protocol) > 1.0) && $state(-keepalive)} { + # Send this header, because a 1.1 server is not compelled to treat + # this as the default. + set ConnVal keep-alive + } elseif {($state(-protocol) > 1.0)} { + # RFC2616 sec 8.1.2.1 + set ConnVal close + } else { + # ($state(-protocol) <= 1.0) + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + set ConnVal close + } + # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by + # Pat Thoyts). + if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { + SendHeader $token Proxy-Authorization $http(-proxyauth) + } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" + set accept_encoding_seen 0 + set content_type_seen 0 + set connection_seen 0 + foreach {key value} $state(-headers) { + set value [string map [list \n "" \r ""] $value] + set key [string map {" " -} [string trim $key]] + if {[string equal -nocase $key "host"]} { + continue + } + if {[string equal -nocase $key "accept-encoding"]} { + set accept_encoding_seen 1 + } + if {[string equal -nocase $key "accept"]} { + set accept_types_seen 1 + } + if {[string equal -nocase $key "content-type"]} { + set content_type_seen 1 + } + if {[string equal -nocase $key "content-length"]} { + set contDone 1 + set state(querylength) $value + } + if { [string equal -nocase $key "connection"] + && [info exists state(bypass)] + } { + # Value supplied in -headers overrides $ConnVal. + set connection_seen 1 + } elseif {[string equal -nocase $key "connection"]} { + # Remove "close" or "keep-alive" and use our own value. + # In an upgrade request, the upgrade is not guaranteed. + # Value "close" or "keep-alive" tells the server what to do + # if it refuses the upgrade. We send a single "Connection" + # header because some websocket servers, e.g. civetweb, reject + # multiple headers. Bug [d01de3281f] of tcllib/websocket. + set connection_seen 1 + set listVal $state(connectionValues) + if {[set pos [lsearch $listVal close]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + if {[set pos [lsearch $listVal keep-alive]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + lappend listVal $ConnVal + set value [join $listVal {, }] + } + if {[string length $key]} { + SendHeader $token $key $value + } + } + # Allow overriding the Accept header on a per-connection basis. Useful + # for working with REST services. [Bug c11a51c482] + if {!$accept_types_seen} { + SendHeader $token Accept $state(accept-types) + } + if { (!$accept_encoding_seen) + && (![info exists state(-handler)]) + && $http(-zip) + } { + SendHeader $token Accept-Encoding gzip,deflate + } elseif {!$accept_encoding_seen} { + SendHeader $token Accept-Encoding identity + } else { + } + if {!$connection_seen} { + SendHeader $token Connection $ConnVal + } + if {$isQueryChannel && ($state(querylength) == 0)} { + # Try to determine size of data in channel. If we cannot seek, the + # surrounding catch will trap us + + set start [tell $state(-querychannel)] + seek $state(-querychannel) 0 end + set state(querylength) \ + [expr {[tell $state(-querychannel)] - $start}] + seek $state(-querychannel) $start + } + + # Note that we don't do Cookie2; that's much nastier and not normally + # observed in practice either. It also doesn't fix the multitude of + # bugs in the basic cookie spec. + if {$http(-cookiejar) ne ""} { + set cookies "" + set separator "" + foreach {key value} [{*}$http(-cookiejar) \ + getCookies $proto $host $state(path)] { + append cookies $separator $key = $value + set separator "; " + } + if {$cookies ne ""} { + SendHeader $token Cookie $cookies + } + } + + # Flush the request header and set up the fileevent that will either + # push the POST data or read the response. + # + # fileevent note: + # + # It is possible to have both the read and write fileevents active at + # this point. The only scenario it seems to affect is a server that + # closes the connection without reading the POST data. (e.g., early + # versions TclHttpd in various error cases). Depending on the + # platform, the client may or may not be able to get the response from + # the server because of the error it will get trying to write the post + # data. Having both fileevents active changes the timing and the + # behavior, but no two platforms (among Solaris, Linux, and NT) behave + # the same, and none behave all that well in any case. Servers should + # always read their POST data if they expect the client to read their + # response. + + if {$isQuery || $isQueryChannel} { + # POST method. + if {!$content_type_seen} { + SendHeader $token Content-Type $state(-type) + } + if {!$contDone} { + SendHeader $token 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] + # 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 + 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, 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)} { + # 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} + } + + # 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 ""} { + # https handshake errors come here, for + # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg {failed to use socket} + } + Finish $token $msg + } elseif {$state(status) ne "error"} { + Finish $token $err + } + } + 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 +} + +# http::DoneRequest -- +# +# 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 + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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" + # 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 + # value of socketRdState. + # In the nonpipeline case, connection for reading always occurs. + 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 ---- $state(socketinfo) >> conn to $token for HTTP response + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list auto $trWrite] \ + -buffersize $state(-blocksize) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + Log ^D$tk begin receiving response - token $token + + coroutine ${token}--EventCoroutine http::Event $sock $token + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}--EventCoroutine + } + return +} + + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}--EventCoroutine} res opts + if {[info commands ${token}--EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::MakeTransformationChunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res +} + + +# 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 socketClosing + variable $token + upvar 0 $token state + set connId $state(socketinfo) + + 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") + + && [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}(connArgs)] + 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. + set conn [set ${token3}(connArgs)] + #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 + } + return +} + +# http::CancelReadPipeline +# +# Cancel pipelined responses on a closing "Keep-Alive" socket. +# +# - 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. +# +# 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 by CancelReadPipeline} + 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 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. +# - 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. +# +# 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 by CancelWritePipeline} + 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 {token doing} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + upvar 0 $token state + + Log running http::ReplayIfDead for $token $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 {$state(-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($state(socketinfo))] + && ($socketRdState($state(socketinfo)) ne "Rready") + } { + lappend InFlightR $socketRdState($state(socketinfo)) + } elseif {($doing eq "read")} { + lappend InFlightR $token + } + + if { [info exists socketWrState($state(socketinfo))] + && $socketWrState($state(socketinfo)) ni {Wready peNding} + } { + lappend InFlightW $socketWrState($state(socketinfo)) + } elseif {($doing eq "write")} { + lappend InFlightW $token + } + + # Report any inconsistency of $token with socket*state. + if { ($doing eq "read") + && [info exists socketRdState($state(socketinfo))] + && ($token ne $socketRdState($state(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined token $token $doing \ + ne socketRdState($state(socketinfo)) \ + $socketRdState($state(socketinfo)) + + } elseif { + ($doing eq "write") + && [info exists socketWrState($state(socketinfo))] + && ($token ne $socketWrState($state(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined token $token $doing \ + ne socketWrState($state(socketinfo)) \ + $socketWrState($state(socketinfo)) + } + } else { + # One transaction should be in flight. + # socketRdState, socketWrQueue are used. + # socketRdQueue should be empty. + + # Report any inconsistency of $token with socket*state. + if {$token ne $socketRdState($state(socketinfo))} { + Log WARNING - ReplayIfDead nonpipeline token $token $doing \ + ne socketRdState($state(socketinfo)) \ + $socketRdState($state(socketinfo)) + } + + # Report the inconsistency that socketRdQueue is non-empty. + if { [info exists socketRdQueue($state(socketinfo))] + && ($socketRdQueue($state(socketinfo)) ne {}) + } { + Log WARNING - ReplayIfDead nonpipeline token $token $doing \ + has read queue socketRdQueue($state(socketinfo)) \ + $socketRdQueue($state(socketinfo)) ne {} + } + + lappend InFlightW $socketRdState($state(socketinfo)) + set socketRdQueue($state(socketinfo)) {} + } + + set newQueue {} + lappend newQueue {*}$InFlightR + lappend newQueue {*}$socketRdQueue($state(socketinfo)) + lappend newQueue {*}$InFlightW + lappend newQueue {*}$socketWrQueue($state(socketinfo)) + + + # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket. + # Do not change state(status). + # No need to after cancel state(after) - either this is done in + # ReplayCore/ReInit, or Finish is called. + + catch {close $state(sock)} + Unset $state(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 +} + +# 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 + } + ##Log $Rqueue -- $InFlightW -- $Wqueue + set newQueue {} + lappend newQueue {*}$Rqueue + lappend newQueue {*}$InFlightW + lappend newQueue {*}$Wqueue + + # 2. Cleanup - none needed, done by the caller. + + ReplayCore $newQueue + 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) + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (ReInit) + after cancel $state(socketcoro) + unset state(socketcoro) + } + + # Don't alter state(status) - this would trigger http::wait if it is in use. + 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. +# +# 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 TmpSockCounter + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 {![ReInit $token]} { + Log FAILED in http::ReplayCore - NO tmp vars + Log ReplayCore reject $token + Finish $token {cannot send this request again} + return + } + + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + unset state(tmpState) + unset state(tmpOpenCmd) + unset state(tmpConnArgs) + + set state(reusing) 0 + set state(ReusingPlaceholder) 0 + set state(alreadyQueued) 0 + Log ReplayCore replay $token + + # Give the socket a placeholder name before it is created. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + set state(sock) $sock + + # Move the $newQueue into the placeholder socket's socketPhQueue. + set socketPhQueue($sock) {} + foreach tok $newQueue { + if {[ReInit $tok]} { + set ${tok}(reusing) 1 + set ${tok}(sock) $sock + lappend socketPhQueue($sock) $tok + Log ReplayCore replay $tok + } else { + Log ReplayCore reject $tok + set ${tok}(reusing) 1 + set ${tok}(sock) NONE + Finish $tok {cannot send this request again} + } + } + + AsyncTransaction $token + + return +} + +# Data access functions: +# Data - the URL data +# Status - the transaction status: ok, reset, eof, timeout, error +# Code - the HTTP transaction code, e.g., 200 +# Size - the size of the URL data + +proc http::responseBody {token} { + variable $token + upvar 0 $token state + return $state(body) +} +proc http::status {token} { + if {![info exists $token]} { + return "error" + } + variable $token + upvar 0 $token state + return $state(status) +} +proc http::responseLine {token} { + variable $token + upvar 0 $token state + return $state(http) +} +proc http::requestLine {token} { + variable $token + upvar 0 $token state + return $state(requestLine) +} +proc http::responseCode {token} { + variable $token + upvar 0 $token state + if {[regexp {[0-9]{3}} $state(http) numeric_code]} { + return $numeric_code + } else { + return $state(http) + } +} +proc http::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} +proc http::requestHeaders {token args} { + set lenny [llength $args] + if {$lenny > 1} { + return -code error {usage: ::http::requestHeaders token ?headerName?} + } else { + return [Meta $token request {*}$args] + } +} +proc http::responseHeaders {token args} { + set lenny [llength $args] + if {$lenny > 1} { + return -code error {usage: ::http::responseHeaders token ?headerName?} + } else { + return [Meta $token response {*}$args] + } +} +proc http::requestHeaderValue {token header} { + Meta $token request $header VALUE +} +proc http::responseHeaderValue {token header} { + Meta $token response $header VALUE +} +proc http::Meta {token who args} { + variable $token + upvar 0 $token state + + if {$who eq {request}} { + set whom requestHeaders + } elseif {$who eq {response}} { + set whom meta + } else { + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + } + + set header [string tolower [lindex $args 0]] + set how [string tolower [lindex $args 1]] + set lenny [llength $args] + if {$lenny == 0} { + return $state($whom) + } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} { + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + } else { + set result {} + set combined {} + foreach {key value} $state($whom) { + if {$key eq $header} { + lappend result $key $value + append combined $value {, } + } + } + if {$lenny == 1} { + return $result + } else { + return [string range $combined 0 end-2] + } + } +} + + +# ------------------------------------------------------------------------------ +# Proc http::responseInfo +# ------------------------------------------------------------------------------ +# Command to return a dictionary of the most useful metadata of a HTTP +# response. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: a dict. See man page http(n) for a description of each item. +# ------------------------------------------------------------------------------ + +proc http::responseInfo {token} { + variable $token + upvar 0 $token state + set result {} + foreach {key origin name} { + stage STATE state + status STATE status + responseCode STATE responseCode + reasonPhrase STATE reasonPhrase + contentType STATE type + binary STATE binary + redirection RESP location + upgrade STATE upgrade + error ERROR - + postError STATE posterror + method STATE method + charset STATE charset + compression STATE coding + httpRequest STATE -protocol + httpResponse STATE httpResponse + url STATE url + connectionRequest REQ connection + connectionResponse RESP connection + connectionActual STATE connection + transferEncoding STATE transfer + totalPost STATE querylength + currentPost STATE queryoffset + totalSize STATE totalsize + currentSize STATE currentsize + proxyUsed STATE proxyUsed + } { + if {$origin eq {STATE}} { + if {[info exists state($name)]} { + dict set result $key $state($name) + } else { + # Should never come here + dict set result $key {} + } + } elseif {$origin eq {REQ}} { + dict set result $key [requestHeaderValue $token $name] + } elseif {$origin eq {RESP}} { + dict set result $key [responseHeaderValue $token $name] + } elseif {$origin eq {ERROR}} { + # Don't flood the dict with data. The command ::http::error is + # available. + if {[info exists state(error)]} { + set msg [lindex $state(error) 0] + } else { + set msg {} + } + dict set result $key $msg + } else { + # Should never come here + dict set result $key {} + } + } + return $result +} +proc http::error {token} { + variable $token + upvar 0 $token state + if {[info exists state(error)]} { + return $state(error) + } + return +} +proc http::postError {token} { + variable $token + upvar 0 $token state + if {[info exists state(postErrorFull)]} { + return $state(postErrorFull) + } + return +} + +# http::cleanup +# +# Garbage collect the state associated with a transaction +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# Unsets the state array. + +proc http::cleanup {token} { + variable $token + upvar 0 $token state + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (cleanup) + after cancel $state(socketcoro) + unset state(socketcoro) + } + if {[info exists state]} { + unset state + } + return +} + +# http::Connect +# +# This callback is made when an asynchronous connection completes. +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# Sets the status of the connection, which unblocks +# the waiting geturl call + +proc http::Connect {token proto phost srvurl} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + if {[catch {eof $state(sock)} tmp] || $tmp} { + set err "due to unexpected EOF" + } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { + # set err is done in test + } else { + # All OK + set state(state) connecting + fileevent $state(sock) writable {} + ::http::Connected $token $proto $phost $srvurl + return + } + + # Error cases. + 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. + 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" + return +} + +# http::Write +# +# Write POST query data to the socket +# +# Arguments +# token The token for the connection +# +# Side Effects +# Write the socket and handle callbacks. + +proc http::Write {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 + set done 0 + if {[catch { + # Catch I/O errors on dead sockets + + 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}]] + incr state(queryoffset) $state(-queryblocksize) + if {$state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) + set done 1 + } + } else { + # 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)]} { + set done 1 + } + } + } err opts]} { + # Do not call Finish here, but instead let the read half of the socket + # process whatever server reply there is to get. + set state(posterror) $err + set info [dict get $opts -errorinfo] + set code [dict get $opts -code] + set state(postErrorFull) [list $err $info $code] + set done 1 + } + + if {$done} { + catch {flush $sock} + fileevent $sock writable {} + 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. + + if {[string length $state(-queryprogress)]} { + namespace eval :: $state(-queryprogress) \ + [list $token $state(querylength) $state(queryoffset)] + } + return +} + +# http::Event +# +# 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. +# token The token returned from http::geturl +# +# Side Effects +# Read the socket and handle callbacks. + +proc http::Event {sock token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + while 1 { + yield + ##Log Event call - token $token + + if {![info exists state]} { + Log "Event $sock with invalid token '$token' - remote close?" + if {!([catch {eof $sock} tmp] || $tmp)} { + if {[set d [read $sock]] ne ""} { + Log "WARNING: additional data left on closed socket\ + - token $token" + } else { + } + } else { + } + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + return + } else { + } + 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]] + } else { + } + + 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 + } else { + } + # 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 { + # https handshake errors come here, for + # Tcl 8.7 with http::SecureProxyConnect. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg $nsl + } + Log ^X$tk end of response (error) - token $token + Finish $token $msg + return + } + } elseif {$nsl >= 0} { + ##Log - connecting 1 - token $token + set state(state) "header" + } elseif { ([catch {eof $sock} tmp] || $tmp) + && [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 { + } + + # 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 { + } + } 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) == "") + || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) + } { + set state(state) "connecting" + continue + # This was a "return" in the pre-coroutine code. + } else { + } + + # We have $state(http) so let's split it into its components. + if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \ + -> httpResponse responseCode reasonPhrase] + } { + set state(httpResponse) $httpResponse + set state(responseCode) $responseCode + set state(reasonPhrase) $reasonPhrase + } else { + set state(httpResponse) $state(http) + set state(responseCode) $state(http) + set state(reasonPhrase) $state(http) + } + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ("keep-alive" in $state(connection)) + && ($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 + } else { + } + + # 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))]) + && ("close" in $state(connection)) + && ($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. + Log $token socket will close after this transaction + # 1. Cancel socket-assignment coro events that have not yet + # launched, and add the tokens to the write queue. + if {[info exists socketCoEvent($state(socketinfo))]} { + foreach {tok can} $socketCoEvent($state(socketinfo)) { + lappend socketWrQueue($state(socketinfo)) $tok + unset -nocomplain ${tok}(socketcoro) + after cancel $can + Log $tok Cancel socket after-idle event (Event) + Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro + } + set socketCoEvent($state(socketinfo)) {} + } else { + } + + 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))] + + # - 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 tokenVal $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenVal}(after)]} { + after cancel [set ${tokenVal}(after)] + unset ${tokenVal}(after) + } else { + } + # Tokens in the read queue have no (socketcoro) to + # cancel. + } + } else { + set socketPlayCmd($state(socketinfo)) \ + {ReplayIfClose Wready {} {}} + } + + # Do not allow further connections on this socket (but + # geturl can add new requests to the replay). + set socketClosing($state(socketinfo)) 1 + } else { + } + + set state(state) body + + # According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated "Connection:" list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + # Done here to support combining duplicate header field's values. + if { [info exists state(connection)] + && ("close" ni $state(connection)) + && ("keep-alive" ni $state(connection)) + } { + lappend state(connection) "keep-alive" + } else { + } + + # 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 + } elseif { + ($state(method) eq {CONNECT}) + && [string is integer -strict $state(responseCode)] + && ($state(responseCode) >= 200) + && ($state(responseCode) < 300) + } { + # A successful CONNECT response has no body. + # (An unsuccessful CONNECT has headers and body.) + # The code below is abstracted from Eot/Finish, but + # keeps the socket open. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + set state(state) complete + set state(status) ok + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if { [info exists state(-command)] + && (![info exists state(done-command-cb)]) + } { + set state(done-command-cb) yes + if {[catch {namespace eval :: $state(-command) $token} err]} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + return + } else { + } + + # - 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 + # (totalsize == 0). + + if { (!( [info exists state(connection)] + && ("close" in $state(connection)) + ) + ) + && ($state(transfer) eq {}) + && ($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 + } else { + } + + # 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 + } else { + } + if {[info exists state(-channel)]} { + if {$state(binary) || [llength [ContentEncoding $token]]} { + fconfigure $state(-channel) -translation binary + } else { + } + if {![info exists state(-handler)]} { + # Initiate a sequence of background fcopies. + fileevent $sock readable {} + rename ${token}--EventCoroutine {} + CopyStart $sock $token + return + } else { + } + } else { + } + } elseif {$nhl > 0} { + # Process header lines. + ##Log header - token $token - $line + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + set key [string tolower $key] + switch -- $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 { + # RFC 7230 Section 6.1 states that a comma-separated + # list is an acceptable value. + if {![info exists state(connectionRespFlag)]} { + # This is the first "Connection" response header. + # Scrub the earlier value set by iniitialisation. + set state(connectionRespFlag) {} + set state(connection) {} + } + foreach el [SplitCommaSeparatedFieldValue $value] { + lappend state(connection) [string tolower $el] + } + } + upgrade { + set state(upgrade) [string trim $value] + } + set-cookie { + if {$http(-cookiejar) ne ""} { + ParseCookie $token [string trim $value] + } else { + } + } + } + lappend state(meta) $key [string trim $value] + } else { + } + } else { + } + } else { + # Now reading body + ##Log body - token $token + if {[catch { + if {[info exists state(-handler)]} { + set n [namespace 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 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. + set state(state) complete + } else { + } + 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 + } + } 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 + 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 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 + 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 chunk $n cumul $state(log_size) -\ + token $token + } else { + } + 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 + } else { + } + # 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, or eof. + ##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 + 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 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 + } else { + } + } + # 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 another $n currentsize $c totalsize $t -\ + token $token + } else { + } + # 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 + } else { + } + } else { + } + } err]} { + Log ^X$tk end of response (error ${err}) - token $token + Finish $token $err + return + } else { + if {[info exists state(-progress)]} { + namespace eval :: $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } else { + } + } + } + + # 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} { + # [eof sock] succeeded and the result was 1 + ##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 { + # open connection closed on a token that has been cleaned up. + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + } + } else { + # EITHER [eof sock] failed - presumed done by Eot + # OR [eof sock] succeeded and the result was 0 + } + } + 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 +# the data as binary. [Bug 838e99a76d] +# +# Arguments +# type The content-type of the data. +# +# Results: +# Boolean, true if we definitely should be binary. + +proc http::IsBinaryContentType {type} { + lassign [split [string tolower $type] "/;"] major minor + if {$major eq "text"} { + return false + } + # There's a bunch of XML-as-application-format things about. See RFC 3023 + # and so on. + if {$major eq "application"} { + set minor [string trimright $minor] + if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} { + return false + } + } + # Not just application/foobar+xml but also image/svg+xml, so let us not + # restrict things for now... + if {[string match "*+xml" $minor]} { + return false + } + return true +} + +proc http::ParseCookie {token value} { + variable http + variable CookieRE + variable $token + upvar 0 $token state + + if {![regexp $CookieRE $value -> cookiename cookieval opts]} { + # Bad cookie! No biscuit! + return + } + + # Convert the options into a list before feeding into the cookie store; + # ugly, but quite easy. + set realopts {hostonly 1 path / secure 0 httponly 0} + dict set realopts origin $state(host) + dict set realopts domain $state(host) + foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { + regexp {^(.*?)(?:=(.*))?$} $option -> optname optval + switch -exact -- [string tolower $optname] { + expires { + if {[catch { + #Sun, 06 Nov 1994 08:49:37 GMT + dict set realopts expires \ + [clock scan $optval -format "%a, %d %b %Y %T %Z"] + }] && [catch { + # Google does this one + #Mon, 01-Jan-1990 00:00:00 GMT + dict set realopts expires \ + [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] + }] && [catch { + # This is in the RFC, but it is also in the original + # Netscape cookie spec, now online at: + # + #Sunday, 06-Nov-94 08:49:37 GMT + dict set realopts expires \ + [clock scan $optval -format "%A, %d-%b-%y %T %Z"] + }]} {catch { + #Sun Nov 6 08:49:37 1994 + dict set realopts expires \ + [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] + }} + } + max-age { + # Normalize + if {[string is integer -strict $optval]} { + dict set realopts expires [expr {[clock seconds] + $optval}] + } + } + domain { + # From the domain-matches definition [RFC 2109, section 2]: + # Host A's name domain-matches host B's if [...] + # A is a FQDN string and has the form NB, where N is a + # non-empty name string, B has the form .B', and B' is a + # FQDN string. (So, x.y.com domain-matches .y.com but + # not y.com.) + if {$optval ne "" && ![string match *. $optval]} { + dict set realopts domain [string trimleft $optval "."] + dict set realopts hostonly [expr { + ! [string match .* $optval] + }] + } + } + path { + if {[string match /* $optval]} { + dict set realopts path $optval + } + } + secure - httponly { + dict set realopts [string tolower $optname] 1 + } + } + } + dict set realopts key $cookiename + dict set realopts value $cookieval + {*}$http(-cookiejar) storeCookie $realopts +} + +# http::GetTextLine -- +# +# Get one line with the stream in crlf mode. +# Used if Transfer-Encoding is chunked, to read the line that +# reports the size of the following chunk. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. +# +# Arguments +# sock The socket receiving input. +# +# Results: +# The line of text, without trailing newline + +proc http::GetTextLine {sock} { + set tr [fconfigure $sock -translation] + lassign $tr trRead trWrite + 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. +# Used when we expect to read a chunked-encoding +# chunk of known size. + +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 [expr {[catch {eof $sock} tmp] || $tmp}] + 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. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. + +proc http::BlockingGets {sock} { + while 1 { + set count [gets $sock line] + set eof [expr {[catch {eof $sock} tmp] || $tmp}] + if {$count >= 0 || $eof} { + return $line + } else { + yield + } + } +} + +# http::CopyStart +# +# Error handling wrapper around fcopy +# +# Arguments +# sock The socket to copy from +# token The token returned from http::geturl +# +# Side Effects +# This closes the connection upon error + +proc http::CopyStart {sock token {initial 1}} { + upvar 0 $token state + if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # Use the standards-compliant choice. + set coding2 decompress + } else { + set coding2 $coding + } + lappend state(zlib) [zlib stream $coding2] + } + MakeTransformationChunked $sock [namespace code [list CopyChunk $token]] + } else { + if {$initial} { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # Use the standards-compliant choice. + set coding2 decompress + } else { + set coding2 $coding + } + zlib push $coding2 $sock + } + } + 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]} { + Finish $token $err + } + } + return +} + +proc http::CopyChunk {token chunk} { + upvar 0 $token state + if {[set count [string length $chunk]]} { + incr state(currentsize) $count + if {[info exists state(zlib)]} { + foreach stream $state(zlib) { + set chunk [$stream add $chunk] + } + } + puts -nonewline $state(-channel) $chunk + if {[info exists state(-progress)]} { + namespace eval :: [linsert $state(-progress) end \ + $token $state(totalsize) $state(currentsize)] + } + } else { + Log "CopyChunk Finish - token $token" + if {[info exists state(zlib)]} { + set excess "" + foreach stream $state(zlib) { + catch { + $stream put -finalize $excess + set excess "" + set overflood "" + while {[set overflood [$stream get]] ne ""} { append excess $overflood } + } + } + puts -nonewline $state(-channel) $excess + foreach stream $state(zlib) { $stream close } + unset state(zlib) + } + Eot $token ;# FIX ME: pipelining. + } + return +} + +# http::CopyDone +# +# fcopy completion callback +# +# Arguments +# token The token returned from http::geturl +# count The amount transferred +# +# Side Effects +# Invokes callbacks + +proc http::CopyDone {token count {error {}}} { + variable $token + upvar 0 $token state + set sock $state(sock) + incr state(currentsize) $count + if {[info exists state(-progress)]} { + namespace eval :: $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } + # At this point the token may have been reset. + if {[string length $error]} { + Finish $token $error + } elseif {[catch {eof $sock} iseof] || $iseof} { + Eot $token + } else { + CopyStart $sock $token 0 + } + return +} + +# 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. +# +# 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 (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 condition other than +# premature EOF. +# +# Side Effects +# Clean up the socket + +proc http::Eot {token {reason {}}} { + variable $token + upvar 0 $token state + 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 + } + + if {[string length $state(body)] > 0} { + if {[catch { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # First try the standards-compliant choice. + set coding2 decompress + if {[catch {zlib $coding2 $state(body)} result]} { + # If that fails, try the MS non-compliant choice. + set coding2 inflate + set state(body) [zlib $coding2 $state(body)] + } else { + # error {failed at standards-compliant deflate} + set state(body) $result + } + } else { + set state(body) [zlib $coding $state(body)] + } + } + } err]} { + Log "error doing decompression for token $token: $err" + Finish $token $err + return + } + + 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 + # encodings for. + + set enc [CharsetToEncoding $state(charset)] + if {$enc ne "binary"} { + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + } else { + set state(body) [encoding convertfrom $enc $state(body)] + } + } + + # Translate text line endings. + set state(body) [string map {\r\n \n \r \n} $state(body)] + } + if {[info exists state(-guesstype)] && $state(-guesstype)} { + GuessType $token + } + } + Finish $token $reason + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::GuessType +# ------------------------------------------------------------------------------ +# Command to attempt limited analysis of a resource with undetermined +# Content-Type, i.e. "application/octet-stream". This value can be set for two +# reasons: +# (a) by the server, in a Content-Type header +# (b) by http::geturl, as the default value if the server does not supply a +# Content-Type header. +# +# This command converts a resource if: +# (1) it has type application/octet-stream +# (2) it begins with an XML declaration "?" +# (3) one tag is named "encoding" and has a recognised value; or no "encoding" +# tag exists (defaulting to utf-8) +# +# RFC 9110 Sec. 8.3 states: +# "If a Content-Type header field is not present, the recipient MAY either +# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1) +# or examine the data to determine its type." +# +# The RFC goes on to describe the pitfalls of "MIME sniffing", including +# possible security risks. +# +# Arguments: +# token - connection token +# +# Return Value: (boolean) true iff a change has been made +# ------------------------------------------------------------------------------ + +proc http::GuessType {token} { + variable $token + upvar 0 $token state + + if {$state(type) ne {application/octet-stream}} { + return 0 + } + + set body $state(body) + # e.g. { ...} + + if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { + return 0 + } + # e.g. {} + + set contents [regsub -- {[[:space:]]+} $match { }] + set contents [string range [string tolower $contents] 6 end-2] + # e.g. {version="1.0" encoding="utf-8"} + # without excess whitespace or upper-case letters + + if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { + return 0 + } + # The application/xml default encoding: + set res utf-8 + + set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents] + foreach tag $tagList { + regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value + if {$name eq {encoding}} { + set res $value + } + } + set enc [CharsetToEncoding $res] + if {$enc eq "binary"} { + return 0 + } + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + } else { + set state(body) [encoding convertfrom $enc $state(body)] + } + set state(body) [string map {\r\n \n \r \n} $state(body)] + set state(type) application/xml + set state(binary) 0 + set state(charset) $res + return 1 +} + + +# http::wait -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# +# Results: +# The status after the wait. + +proc http::wait {token} { + variable $token + upvar 0 $token state + + if {![info exists state(status)] || $state(status) eq ""} { + # We must wait on the original variable name, not the upvar alias + vwait ${token}(status) + } + + return [status $token] +} + +# http::formatQuery -- +# +# See documentation for details. Call http::formatQuery with an even +# number of arguments, where the first is a name, the second is a value, +# the third is another name, and so on. +# +# Arguments: +# args A list of name-value pairs. +# +# Results: +# 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 { + append result $sep [quoteString $i] + if {$sep eq "="} { + set sep & + } else { + set sep = + } + } + return $result +} + +# http::quoteString -- +# +# Do x-www-urlencoded character mapping +# +# Arguments: +# string The string the needs to be encoded +# +# Results: +# The encoded string + +proc http::quoteString {string} { + variable http + variable formMap + + # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use + # a pre-computed map and [string map] to do the conversion (much faster + # than [regsub]/[subst]). [Bug 1020491] + + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set string [encoding convertto -profile tcl8 $http(-urlencoding) $string] + } else { + set string [encoding convertto $http(-urlencoding) $string] + } + return [string map $formMap $string] +} + +# http::ProxyRequired -- +# Default proxy filter. +# +# Arguments: +# host The destination host +# +# Results: +# The current proxy settings + +proc http::ProxyRequired {host} { + variable http + if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { + return + } + if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { + set port 8080 + } else { + set port $http(-proxyport) + } + + # Simple test (cf. autoproxy) for hosts that must be accessed directly, + # not through the proxy server. + foreach domain $http(-proxynot) { + if {[string match -nocase $domain $host]} { + return {} + } + } + return [list $http(-proxyhost) $port] +} + +# http::CharsetToEncoding -- +# +# Tries to map a given IANA charset to a tcl encoding. If no encoding +# can be found, returns binary. +# + +proc http::CharsetToEncoding {charset} { + variable encodings + + set charset [string tolower $charset] + if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { + set encoding "iso8859-$num" + } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { + set encoding "iso2022-$ext" + } elseif {[regexp {shift[-_]?jis} $charset]} { + set encoding "shiftjis" + } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { + set encoding "cp$num" + } elseif {$charset eq "us-ascii"} { + set encoding "ascii" + } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { + switch -- $num { + 5 {set encoding "iso8859-9"} + 1 - 2 - 3 { + set encoding "iso8859-$num" + } + default { + set encoding "binary" + } + } + } else { + # other charset, like euc-xx, utf-8,... may directly map to encoding + set encoding $charset + } + set idx [lsearch -exact $encodings $encoding] + if {$idx >= 0} { + return $encoding + } else { + return "binary" + } +} + + +# ------------------------------------------------------------------------------ +# Proc http::ContentEncoding +# ------------------------------------------------------------------------------ +# Return the list of content-encoding transformations we need to do in order. +# + # -------------------------------------------------------------------------- + # Options for Accept-Encoding, Content-Encoding: the switch command + # -------------------------------------------------------------------------- + # The symbol deflateX allows http to attempt both versions of "deflate", + # unless there is a -channel - for a -channel, only "decompress" is tried. + # Alternative/extra lines for switch: + # The standards-compliant version of "deflate" can be chosen with: + # deflate { lappend r decompress } + # The Microsoft non-compliant version of "deflate" can be chosen with: + # deflate { lappend r inflate } + # The previously used implementation of "compress", which appears to be + # incorrect and is rarely used by web servers, can be chosen with: + # compress - x-compress { lappend r decompress } + # -------------------------------------------------------------------------- +# +# Arguments: +# token - Connection token. +# +# Return Value: list +# ------------------------------------------------------------------------------ + +proc http::ContentEncoding {token} { + upvar 0 $token state + set r {} + if {[info exists state(coding)]} { + foreach coding [split $state(coding) ,] { + switch -exact -- $coding { + deflate { lappend r deflateX } + gzip - x-gzip { lappend r gunzip } + identity {} + br { + return -code error\ + "content-encoding \"br\" not implemented" + } + default { + Log "unknown content-encoding \"$coding\" ignored" + } + } + } + } + return $r +} + +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 + } + } +} + +# http::SplitCommaSeparatedFieldValue -- +# Return the individual values of a comma-separated field value. +# +# Arguments: +# fieldValue Comma-separated header field value. +# +# Results: +# List of values. +proc http::SplitCommaSeparatedFieldValue {fieldValue} { + set r {} + foreach el [split $fieldValue ,] { + lappend r [string trim $el] + } + return $r +} + + +# http::GetFieldValue -- +# Return the value of a header field. +# +# Arguments: +# headers Headers key-value list +# fieldName Name of header field whose value to return. +# +# Results: +# The value of the fieldName header field +# +# Field names are matched case-insensitively (RFC 7230 Section 3.2). +# +# If the field is present multiple times, it is assumed that the field is +# defined as a comma-separated list and the values are combined (by separating +# them with commas, see RFC 7230 Section 3.2.2) and returned at once. +proc http::GetFieldValue {headers fieldName} { + set r {} + foreach {field value} $headers { + if {[string equal -nocase $fieldName $field]} { + if {$r eq {}} { + set r $value + } else { + append r ", $value" + } + } + } + return $r +} + +proc http::MakeTransformationChunked {chan command} { + coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command + chan event $chan readable [namespace current]::dechunk$chan + return +} + +interp alias {} http::data {} http::responseBody +interp alias {} http::code {} http::responseLine +interp alias {} http::mapReply {} http::quoteString +interp alias {} http::meta {} http::responseHeaders +interp alias {} http::metaValue {} http::responseHeaderValue +interp alias {} http::ncode {} http::responseCode + + +# ------------------------------------------------------------------------------ +# Proc http::socketForTls +# ------------------------------------------------------------------------------ +# Command to use in place of ::socket as the value of ::tls::socketCmd. +# This command does the same as http::socket, and also handles https connections +# through a proxy server. +# +# Notes. +# - The proxy server works differently for https and http. This implementation +# is for https. The proxy for http is implemented in http::CreateToken (in +# code that was previously part of http::geturl). +# - This code implicitly uses the tls options set for https in a call to +# http::register, and does not need to call commands tls::*. This simple +# implementation is possible because tls uses a callback to ::socket that can +# be redirected by changing the value of ::tls::socketCmd. +# +# Arguments: +# args - as for ::socket +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ + +proc http::socketForTls {args} { + variable http + set host [lindex $args end-1] + set port [lindex $args end] + if { ($http(-proxyfilter) ne {}) + && (![catch {$http(-proxyfilter) $host} proxy]) + } { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } else { + set phost {} + set pport {} + } + if {$phost eq ""} { + set sock [::http::socket {*}$args] + } else { + set sock [::http::SecureProxyConnect {*}$args $phost $pport] + } + return $sock +} + + +# ------------------------------------------------------------------------------ +# Proc http::SecureProxyConnect +# ------------------------------------------------------------------------------ +# Command to open a socket through a proxy server to a remote server for use by +# tls. The caller must perform the tls handshake. +# +# Notes +# - Based on patch supplied by Melissa Chawla in ticket 1173760, and +# Proxy-Authorization header cf. autoproxy by Pat Thoyts. +# - Rewritten as a call to http::geturl, because response headers and body are +# needed if the CONNECT request fails. CONNECT is implemented for this case +# only, by state(bypass). +# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT. +# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014), +# RFC 9112 (June 2022). +# +# Arguments: +# args - as for ::socket, ending in host, port; with proxy host, proxy +# port appended. +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ + +proc http::SecureProxyConnect {args} { + variable http + variable ConnectVar + variable ConnectCounter + variable failedProxyValues + set varName ::http::ConnectVar([incr ConnectCounter]) + + # Extract (non-proxy) target from args. + set host [lindex $args end-3] + set port [lindex $args end-2] + set args [lreplace $args end-3 end-2] + + # Proxy server URL for connection. + # This determines where the socket is opened. + set phost [lindex $args end-1] + set pport [lindex $args end] + if {[string first : $phost] != -1} { + # IPv6 address, wrap it in [] so we can append :pport + set phost "\[${phost}\]" + } + set url http://${phost}:${pport} + # Elements of args other than host and port are not used when + # AsyncTransaction opens a socket. Those elements are -async and the + # -type $tokenName for the https transaction. Option -async is used by + # AsyncTransaction anyway, and -type $tokenName should not be propagated: + # the proxy request adds its own -type value. + + set targ [lsearch -exact $args -type] + if {$targ != -1} { + # Record in the token that this is a proxy call. + set token [lindex $args $targ+1] + upvar 0 ${token} state + set tim $state(-timeout) + set state(proxyUsed) SecureProxyFailed + # This value is overwritten with "SecureProxy" below if the CONNECT is + # successful. If it is unsuccessful, the socket will be closed + # below, and so in this unsuccessful case there are no other transactions + # whose (proxyUsed) must be updated. + } else { + set tim 0 + } + if {$tim == 0} { + # Do not use infinite timeout for the proxy. + set tim 30000 + } + + # Prepare and send a CONNECT request to the proxy, using + # code similar to http::geturl. + set requestHeaders [list Host $host] + lappend requestHeaders Connection keep-alive + if {$http(-proxyauth) != {}} { + lappend requestHeaders Proxy-Authorization $http(-proxyauth) + } + + set token2 [CreateToken $url -keepalive 0 -timeout $tim \ + -headers $requestHeaders -command [list http::AllDone $varName]] + variable $token2 + upvar 0 $token2 state2 + + # Kludges: + # Setting this variable overrides the HTTP request line and also allows + # -headers to override the Connection: header set by -keepalive. + # The arguments "-keepalive 0" ensure that when Finish is called for an + # unsuccessful request, the socket is always closed. + set state2(bypass) "CONNECT $host:$port HTTP/1.1" + + AsyncTransaction $token2 + + if {[info coroutine] ne {}} { + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName + } else { + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName + } + unset $varName + + if { ($state2(state) ne "complete") + || ($state2(status) ne "ok") + || (![string is integer -strict $state2(responseCode)]) + } { + set msg {the HTTP request to the proxy server did not return a valid\ + and complete response} + if {[info exists state2(error)]} { + append msg ": " [lindex $state2(error) 0] + } + cleanup $token2 + return -code error $msg + } + + set code $state2(responseCode) + + if {($code >= 200) && ($code < 300)} { + # All OK. The caller in package tls will now call "tls::import $sock". + # The cleanup command does not close $sock. + # Other tidying was done in http::Event. + + # If this is a persistent socket, any other transactions that are + # already marked to use the socket will have their (proxyUsed) updated + # when http::OpenSocket calls http::ConfigureNewSocket. + set state(proxyUsed) SecureProxy + set sock $state2(sock) + cleanup $token2 + return $sock + } + + if {$targ != -1} { + # Non-OK HTTP status code; token is known because option -type + # (cf. targ) was passed through tcltls, and so the useful + # parts of the proxy's response can be copied to state(*). + # Do not copy state2(sock). + # Return the proxy response to the caller of geturl. + foreach name $failedProxyValues { + if {[info exists state2($name)]} { + set state($name) $state2($name) + } + } + set state(connection) close + set msg "proxy connect failed: $code" + # - This error message will be detected by http::OpenSocket and will + # cause it to present the proxy's HTTP response as that of the + # original $token transaction, identified only by state(proxyUsed) + # as the response of the proxy. + # - The cases where this would mislead the caller of http::geturl are + # given a different value of msg (below) so that http::OpenSocket will + # treat them as errors, but will preserve the $token array for + # inspection by the caller. + # - Status code 305 (Proxy Required) was deprecated for security reasons + # in RFC 2616 (June 1999) and in any case should never be served by a + # proxy. + # - Other 3xx responses from the proxy are inappropriate, and should not + # occur. + # - A 401 response from the proxy is inappropriate, and should not + # occur. It would be confusing if returned to the caller. + + if {($code >= 300) && ($code < 400)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate $code redirect" + set loc [responseHeaderValue $token2 location] + if {$loc ne {}} { + append msg "to " $loc + } + } elseif {($code == 401)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate 401 request for target-host credentials" + } else { + } + } else { + set msg "connection to proxy failed with status code $code" + } + + # - ${token2}(sock) has already been closed because -keepalive 0. + # - Error return does not pass the socket ID to the + # $token transaction, which retains its socket placeholder. + cleanup $token2 + return -code error $msg +} + +proc http::AllDone {varName args} { + set $varName done + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::socket +# ------------------------------------------------------------------------------ +# This command is a drop-in replacement for ::socket. +# Arguments and return value as for ::socket. +# +# Notes. +# - http::socket is specified in place of ::socket by the definition of urlTypes +# in the namespace header of this file (http.tcl). +# - The command makes a simple call to ::socket unless the user has called +# http::config to change the value of -threadlevel from the default value 0. +# - For -threadlevel 1 or 2, if the Thread package is available, the command +# waits in the event loop while the socket is opened in another thread. This +# is a workaround for bug [824251] - it prevents http::geturl from blocking +# the event loop if the DNS lookup or server connection is slow. +# - FIXME Use a thread pool if connections are very frequent. +# - FIXME The peer thread can transfer the socket only to the main interpreter +# in the present thread. Therefore this code works only if this script runs +# in the main interpreter. In a child interpreter, the parent must alias a +# command to ::http::socket in the child, run http::socket in the parent, +# and then transfer the socket to the child. +# - The http::socket command is simple, and can easily be replaced with an +# alternative command that uses a different technique to open a socket while +# entering the event loop. +# - Unexpected behaviour by thread::send -async (Thread 2.8.6). +# An error in thread::send -async causes return of just the error message +# (not the expected 3 elements), and raises a bgerror in the main thread. +# Hence wrap the command with catch as a precaution. +# ------------------------------------------------------------------------------ + +proc http::socket {args} { + variable ThreadVar + variable ThreadCounter + variable http + + LoadThreadIfNeeded + + set targ [lsearch -exact $args -type] + if {$targ != -1} { + set token [lindex $args $targ+1] + set args [lreplace $args $targ $targ+1] + upvar 0 $token state + } + + if {!$http(usingThread)} { + # Use plain "::socket". This is the default. + return [eval ::socket $args] + } + + set defcmd ::socket + set sockargs $args + set script " + set code \[catch { + [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] + [list ::SockInThread [thread::id] $defcmd $sockargs] + } result opts\] + list \$code \$opts \$result + " + + set state(tid) [thread::create] + set varName ::http::ThreadVar([incr ThreadCounter]) + thread::send -async $state(tid) $script $varName + Log >T Thread Start Wait $args -- coro [info coroutine] $varName + if {[info coroutine] ne {}} { + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName + } else { + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName + } + Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName] + thread::release $state(tid) + set state(tid) {} + set result [set $varName] + unset $varName + if {(![string is list $result]) || ([llength $result] != 3)} { + return -code error "result from peer thread is not a list of\ + length 3: it is \n$result" + } + lassign $result threadCode threadDict threadResult + if {($threadCode != 0)} { + # This is an error in thread::send. Return the lot. + return -options $threadDict -code error $threadResult + } + + # Now the results of the catch in the peer thread. + lassign $threadResult catchCode errdict sock + + if {($catchCode == 0) && ($sock ni [chan names])} { + return -code error {Transfer of socket from peer thread failed.\ + Check that this script is not running in a child interpreter.} + } + return -options $errdict -code $catchCode $sock +} + +# The commands below are dependencies of http::socket and +# http::SecureProxyConnect and are not used elsewhere. + +# ------------------------------------------------------------------------------ +# Proc http::LoadThreadIfNeeded +# ------------------------------------------------------------------------------ +# Command to load the Thread package if it is needed. If it is needed and not +# loadable, the outcome depends on $http(-threadlevel): +# value 0 => Thread package not required, no problem +# value 1 => operate as if -threadlevel 0 +# value 2 => error return +# +# Arguments: none +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::LoadThreadIfNeeded {} { + variable http + if {$http(usingThread) || ($http(-threadlevel) == 0)} { + return + } + if {[catch {package require Thread}]} { + if {$http(-threadlevel) == 2} { + set msg {[http::config -threadlevel] has value 2,\ + but the Thread package is not available} + return -code error $msg + } + return + } + set http(usingThread) 1 + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::SockInThread +# ------------------------------------------------------------------------------ +# Command http::socket is a ::socket replacement. It defines and runs this +# command, http::SockInThread, in a peer thread. +# +# Arguments: +# caller +# defcmd +# sockargs +# +# Return value: list of values that describe the outcome. The return is +# intended to be a normal (non-error) return in all cases. +# ------------------------------------------------------------------------------ + +proc http::SockInThread {caller defcmd sockargs} { + package require Thread + + set catchCode [catch {eval $defcmd $sockargs} sock errdict] + if {$catchCode == 0} { + set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] + } + return [list $catchCode $errdict $sock] +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::cwait +# ------------------------------------------------------------------------------ +# Command to substitute for vwait, without the ordering issues. +# A command that uses cwait must be a coroutine that is launched by an event, +# e.g. fileevent or after idle, and has no calling code to be resumed upon +# "yield". It cannot return a value. +# +# Arguments: +# varName - fully-qualified name of the variable that the calling script +# will write to resume the coroutine. Any scalar variable or +# array element is permitted. +# coroName - (optional) name of the coroutine to be called when varName is +# written - defaults to this coroutine +# timeout - (optional) timeout value in ms +# timeoutValue - (optional) value to assign to varName if there is a timeout +# +# Return Value: none +# ------------------------------------------------------------------------------ + +namespace eval http::cwaiter { + namespace export cwait + variable log {} + variable logOn 0 +} + +proc http::cwaiter::cwait { + varName {coroName {}} {timeout {}} {timeoutValue {}} +} { + set thisCoro [info coroutine] + if {$thisCoro eq {}} { + return -code error {cwait cannot be called outside a coroutine} + } + if {$coroName eq {}} { + set coroName $thisCoro + } + if {[string range $varName 0 1] ne {::}} { + return -code error {argument varName must be fully qualified} + } + if {$timeout eq {}} { + set toe {} + } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { + set toe [after $timeout [list set $varName $timeoutValue]] + } else { + return -code error {if timeout is supplied it must be a positive integer} + } + + set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] + trace add variable $varName write $cmd + CoLog "Yield $varName $coroName" + yield + CoLog "Resume $varName $coroName" + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::CwaitHelper +# ------------------------------------------------------------------------------ +# Helper command called by the trace set by cwait. +# - Ignores the arguments added by trace. +# - A simple call to $coroName works, and in error cases gives a suitable stack +# trace, but because it is inside a trace the headline error message is +# something like {can't set "::Result(6)": error}, not the actual +# error. So let the trace command return. +# - Remove the trace immediately. We don't want multiple calls. +# ------------------------------------------------------------------------------ + +proc http::cwaiter::CwaitHelper {varName coroName toe args} { + CoLog "got $varName for $coroName" + set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] + trace remove variable $varName write $cmd + after cancel $toe + + after 0 $coroName + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::LogInit +# ------------------------------------------------------------------------------ +# Call this command to initiate debug logging and clear the log. +# ------------------------------------------------------------------------------ + +proc http::cwaiter::LogInit {} { + variable log + variable logOn + set log {} + set logOn 1 + return +} + +proc http::cwaiter::LogRead {} { + variable log + return $log +} + +proc http::cwaiter::CoLog {msg} { + variable log + variable logOn + if {$logOn} { + append log $msg \n + } + return +} + +namespace eval http { + namespace import ::http::cwaiter::* +} + +# Local variables: +# indent-tabs-mode: t +# End: diff --git a/src/build.tcl b/src/build.tcl index 719accbf..ee541f5b 100644 --- a/src/build.tcl +++ b/src/build.tcl @@ -1,6 +1,6 @@ #!/bin/sh # -*- tcl -*- \ # 'build.tcl' name as required by kettle -# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...` +# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...`\ exec ./kettle -f "$0" "${1+$@}" kettle doc diff --git a/src/make.tcl b/src/make.tcl index 1154c2a2..64b1794c 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -15,7 +15,7 @@ namespace eval ::punkmake { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project get-project-info] + variable known_commands [list project get-project-info shell bootsupport] } if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" @@ -251,11 +251,22 @@ if {$::punkmake::command eq "get-project-info"} { } if {$::punkmake::command eq "shell"} { - #package require pu + package require punk + package require punk::repl + puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + repl::start stdin + exit 1 +} + +if {$::punkmake::command eq "bootsupport"} { + + + exit 1 } + if {$::punkmake::command ne "project"} { puts stderr "Command $::punkmake::command not implemented - aborting." exit 1 @@ -270,7 +281,11 @@ file mkdir $target_modules_base #external libs and modules first - and any supporting files - no 'building' required if {[file exists $sourcefolder/vendorlib]} { - #unpublish README.md from source folder - but on the root one + #unpublish README.md from source folder - but only the root one + #-unpublish_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) set unpublish [list\ README.md\ ] @@ -279,7 +294,8 @@ if {[file exists $sourcefolder/vendorlib]} { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" - puts stderr "Copied [llength $copied] vendor libs from src/vendorlib to $projectroot/lib" + flush stdout + puts stderr "Copied [llength $copied] vendor lib files from src/vendorlib to $projectroot/lib" foreach f $copied { puts stdout "COPIED $f" } @@ -296,7 +312,8 @@ if {[file exists $sourcefolder/vendormodules]} { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" - puts stderr "Copied [llength $copied] vendor modules from src/vendormodules to $target_modules_base" + flush stdout + puts stderr "Copied [llength $copied] vendor module files from src/vendormodules to $target_modules_base" foreach f $copied { puts stdout "COPIED $f" } @@ -311,7 +328,16 @@ if {[file exists $sourcefolder/vendormodules]} { #e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync #src to src/modules/punk/mix/templates/layouts/project/src - set templatebase $sourcefolder/modules/punk/mix/templates +set layout_update_list [list\ + [list project $sourcefolder/modules/punk/mix/templates]\ + [list basic $sourcefolder/mixtemplates]\ + ] + +foreach layoutinfo $layout_update_list { + lassign $layoutinfo layout templatebase + if {![file exists $templatebase]} { + continue + } set config [dict create\ -make-step sync_templates\ ] @@ -322,8 +348,8 @@ if {[file exists $sourcefolder/vendormodules]} { #---------- set pairs [list] set pairs [list\ - [list $sourcefolder/build.tcl $templatebase/layouts/project/src/build.tcl]\ - [list $sourcefolder/make.tcl $templatebase/layouts/project/src/make.tcl]\ + [list $sourcefolder/build.tcl $templatebase/layouts/$layout/src/build.tcl]\ + [list $sourcefolder/make.tcl $templatebase/layouts/$layout/src/make.tcl]\ ] foreach filepair $pairs { @@ -356,6 +382,7 @@ if {[file exists $sourcefolder/vendormodules]} { $tpl_event end $tpl_event destroy $tpl_installer destroy +} ######################################################## @@ -380,8 +407,10 @@ foreach src_module_dir $source_module_folderlist { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" + flush stdout puts stderr "Copied [llength $copied] non-tm source files from $src_module_dir to $target_modules_base" puts stderr "[llength $sources_unchanged] unchanged source files" + flush stderr puts stdout "--------------------------" } @@ -748,7 +777,7 @@ foreach vfs $vfs_folders { $bin_event targetset_end OK # -- ---------- } else { - $bin_event targetset_end FAILED + $bin_event targetset_end FAILED -note "could not delete } $bin_event destroy $bin_installer destroy diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 8fbf6744..f1d0214b 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -5656,8 +5656,8 @@ namespace eval punk { # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { - set number [punk::objclone unformattednumber] - set number [string map [list _ ""] $number + set number [punk::objclone $unformattednumber] + set number [string map [list _ ""] $number] #normalize using expr - e.g 2e4 -> 20000.0 set number [expr {$number}] # First, extract right hand part of number, up to and including decimal point diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index cd6547d5..c8dcbb18 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -1254,12 +1254,12 @@ namespace eval punk::du { } else { if {$loadstate eq "failed"} { puts stderr "punk::du defaulting to du_dirlisting_generic because twapi load failed" - set_active_function du_dirlisting du_dirlisting_generic + punk::du::active::set_active_function du_dirlisting du_dirlisting_generic } tailcall du_dirlisting_generic $folderpath {*}$args } } else { - set_active_function du_dirlisting du_dirlisting_unix + punk::du::active::set_active_function du_dirlisting du_dirlisting_unix tailcall du_dirlisting_unix $folderpath {*}$args } } diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index ef4605b5..190c2ea1 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/base-0.1.tm @@ -345,7 +345,7 @@ namespace eval punk::mix::base { } proc mix_templates_dir {} { - puts stderr "mix_templates_dir WARNING: deprecated - use get_template_folders instead" + puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" set provide_statement [package ifneeded punk::mix [package require punk::mix]] set tmdir [file dirname [lindex $provide_statement end]] set tpldir $tmdir/mix/templates @@ -355,11 +355,11 @@ namespace eval punk::mix::base { return $tpldir } - #get_template_folders + #get_template_basefolders # scriptpath - file or folder # It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any # The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) - proc get_template_folders {{scriptpath ""}} { + proc get_template_basefolders {{scriptpath ""}} { #1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap) set folderdict [dict create] set template_folder_dict [punk::cap::templates::folders] diff --git a/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm b/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm index 5b0edbe8..9a1f612e 100644 --- a/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/debug-999999.0a1.0.tm @@ -37,9 +37,9 @@ namespace eval punk::mix::commandset::debug { set modulefolders [lib::find_source_module_paths $projectdir] puts stdout "modulefolders: $modulefolders" - set template_folder_dict [punk::mix::base::lib::get_template_folders] - puts stdout "get_template_folders output:" - pdict $template_folder_dict + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + puts stdout "get_template_basefolders output:" + pdict $template_base_dict return } diff --git a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm index 5d724260..ea44281a 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -38,20 +38,20 @@ namespace eval punk::mix::commandset::layout { return [join $templatefiles \n] } proc templatefiles.relative {layout} { - set template_folder_dict [punk::mix::base::lib::get_template_folders] + set template_base_dict [punk::mix::base::lib::get_template_basefolders] - set tpldirs [list] - dict for {tdir folderinfo} $template_folder_dict { - if {[file exists $tdir/layouts/$layout]} { - lappend tpldirs $tdir + set bases_containing_layout [list] + dict for {tbase folderinfo} $template_base_dict { + if {[file exists $tbase/layouts/$layout]} { + lappend bases_containing_layout $tbase } } - if {![llength $tpldirs]} { + if {![llength $bases_containing_layout]} { puts stderr "Unable to locate folder for layout '$layout'" - puts stderr "searched [dict size $template_folder_dict] template folders" + puts stderr "searched [dict size $template_base_dict] template folders" return } - set tpldir [lindex $tpldirs end] + set tpldir [lindex $bases_containing_layout end] set layout_base $tpldir/layouts set layout_dir [file join $layout_base $layout] @@ -74,7 +74,7 @@ namespace eval punk::mix::commandset::layout { } set layouts [list] #set tplfolderdict [punk::cap::templates::folders] - set tplfolderdict [punk::mix::base::lib::get_template_folders] + set tplfolderdict [punk::mix::base::lib::get_template_basefolders] dict for {tdir folderinfo} $tplfolderdict { set layout_base $tdir/layouts #collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) @@ -89,25 +89,25 @@ namespace eval punk::mix::commandset::layout { } namespace eval lib { proc layout_all_files {layout} { - set tplfolderdict [punk::mix::base::lib::get_template_folders] + set tplbasedict [punk::mix::base::lib::get_template_basefolders] set layouts_found [list] - dict for {tpldir folderinfo} $tplfolderdict { - if {[file isdirectory $tpldir/layouts/$layout]} { - lappend layouts_found $tpldir/layouts/$layout + dict for {tplbase folderinfo} $tplbasedict { + if {[file isdirectory $tplbase/layouts/$layout]} { + lappend layouts_found $tplbase/layouts/$layout } } if {![llength $layouts_found]} { puts stderr "layout '$layout' not found." - puts stderr "searched [dict size $tplfolderdict] template folders" - dict for {tpldir pkg} $tplfolderdict { - puts stderr " - $tpldir $pkg" + puts stderr "searched [dict size $tplbasedict] template folders" + dict for {tplbase pkg} $tplbasedict { + puts stderr " - $tplbase $pkg" } return } set layoutfolder [lindex $layouts_found end] if {![file isdirectory $layoutfolder]} { - puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplfolderdict)" + puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" } set file_list [list] util::foreach-file $layoutfolder path { @@ -121,17 +121,17 @@ namespace eval punk::mix::commandset::layout { #todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? proc layout_scan_for_template_files {layout {tags {}}} { #equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" - set tplfolderdict [punk::cap::templates::folders] + set tplbasedict [punk::mix::base::lib::get_template_basefolders] set layouts_found [list] - dict for {tpldir pkg} $tplfolderdict { + dict for {tpldir pkg} $tplbasedict { if {[file isdirectory $tpldir/layouts/$layout]} { lappend layouts_found $tpldir/layouts/$layout } } if {![llength $layouts_found]} { puts stderr "layout '$layout' not found." - puts stderr "searched [dict size $tplfolderdict] template folders" - dict for {tpldir pkg} $tplfolderdict { + puts stderr "searched [dict size $tplbasedict] template folders" + dict for {tpldir pkg} $tplbasedict { puts stderr " - $tpldir $pkg" } return diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 86181aac..90a00a45 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -348,17 +348,17 @@ namespace eval punk::mix::commandset::module { set opts [dict merge $defaults $args] set opt_scriptpath [dict get $opts -scriptpath] - set module_tfolders [list] - set tfolderdict [punk::mix::base::lib::get_template_folders $opt_scriptpath] - dict for {tdir folderinfo} $tfolderdict { - lappend module_tfolders [file join $tdir module] + set module_template_bases [list] + set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] + dict for {tbase folderinfo} $tbasedict { + lappend module_template_bases [file join $tbase modules] } set template_files [list] - foreach fld $module_tfolders { - set matched_files [glob -nocomplain -dir $fld -type f template_*] + foreach basefld $module_template_bases { + set matched_files [glob -nocomplain -dir $basefld -type f template_*] foreach tf $matched_files { if {[string match ignore* $tf]} { continue diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 335f6bb2..61107a51 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -120,8 +120,6 @@ namespace eval punk::mix::commandset::project { return } } - - set startdir [pwd] if {[set in_project [punk::repo::find_project $startdir]] ne ""} { # use this project as source of templates @@ -130,70 +128,35 @@ namespace eval punk::mix::commandset::project { puts stdout "This project will be searched for templates" puts stdout "-------------------------------------------" } - - #todo - detect whether inside cwd-project or inside a different project - set projectdir $projectparentdir/$projectname - if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { - puts stderr "Target location for new project is already within a project: $target_in_project" - error "Nested projects not yet supported aborting" - } - - - set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] - if {![string length $repodb_folder]} { - puts stderr "No usable repository database folder selected for $projectname.fossil file" - return - } - - if {[file exists $repodb_folder/$projectname.fossil]} { - puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" - if {!($opt_force || $opt_update)} { - puts stderr "-force 1 or -update 1 not specified - aborting" - return - } - } - - - - - #punk::mix::commandset::module::lib::templates_dict -scriptpath "" - set template_folder_dict [punk::mix::base::lib::get_template_folders] - - set tpldirs [list] - dict for {tdir folderinfo} $template_folder_dict { - if {[file exists $tdir/layouts/$opt_layout]} { - lappend tpldirs $tdir + set template_base_dict [punk::mix::base::lib::get_template_basefolders] + set template_bases_containing_layout [list] + dict for {tbase folderinfo} $template_base_dict { + if {[file exists $tbase/layouts/$opt_layout]} { + lappend template_bases_containing_layout $tbase } } - if {![llength $tpldirs]} { + if {![llength $template_bases_containing_layout]} { puts stderr "layout '$opt_layout' was not found in template dirs" - puts stderr "searched [dict size $template_folder_dict] template folders" - dict for {tdir folderinfo} $template_folder_dict { - puts stderr " - $tdir $folderinfo" + puts stderr "searched [dict size $template_base_dict] template folders" + dict for {tbase folderinfo} $template_base_dict { + puts stderr " - $tbase $folderinfo" } return } #review: silently use last entry which had the layout (?) - set tpldir [lindex $tpldirs end] - + set templatebase [lindex $template_bases_containing_layout end] - if {[file exists $projectdir] && !($opt_force || $opt_update)} { - puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" - return - } elseif {[file exists $projectdir] && $opt_force} { - puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -force option to overwrite from template" - if {$opt_confirm ni [list 0 no false]} { - set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] - if {[string tolower $answer] ne "y"} { - puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." - return - } - } - } elseif {[file exists $projectdir] && $opt_update} { - puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -update option to add missing items" + + + #todo - detect whether inside cwd-project or inside a different project + set projectdir $projectparentdir/$projectname + if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { + puts stderr "Target location for new project is already within a project: $target_in_project" + error "Nested projects not yet supported aborting" } - + + if {[punk::repo::is_git $projectparentdir]} { puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" @@ -218,30 +181,104 @@ namespace eval punk::mix::commandset::project { } } + + set project_dir_exists [file exists $projectdir] + if {$project_dir_exists && !($opt_force || $opt_update)} { + puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" + return + } elseif {$project_dir_exists && $opt_force} { + puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" + if {$opt_confirm ni [list 0 no false]} { + set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } elseif {$project_dir_exists && $opt_update} { + puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" + } + set fossil_repo_file "" + set is_fossil_root 0 + if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { + set is_fossil_root 1 + set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] + if {$fossil_repo_file ne ""} { + set repodb_folder [file dirname $fossil_repo_file] + } + } - puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" - set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] - if {[dict get $fossilinit exitcode] != 0} { - puts stderr "fossil init failed:" - puts stderr [dict get $fossilinit stderr] - return - } else { - puts stdout "fossil init result:" - puts stdout [dict get $fossilinit stdout] + if {$fossil_repo_file eq ""} { + set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] + if {![string length $repodb_folder]} { + puts stderr "No usable repository database folder selected for $projectname.fossil file" + return + } + } + if {[file exists $repodb_folder/$projectname.fossil]} { + puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" + if {!($opt_force || $opt_update)} { + puts stderr "-force 1 or -update 1 not specified - aborting" + return + } + } + + if {$fossil_repo_file eq ""} { + puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" + set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] + if {[dict get $fossilinit exitcode] != 0} { + puts stderr "fossil init failed:" + puts stderr [dict get $fossilinit stderr] + return + } else { + puts stdout "fossil init result:" + puts stdout [dict get $fossilinit stdout] + } } file mkdir $projectdir - set layout_dir $tpldir/layouts/$opt_layout + + set layout_dir $templatebase/layouts/$opt_layout puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" + set resultdict [dict create] #In this case we need to override the default dir antiglob - as .fossil- folders need to be installed from template ## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] set override_antiglob_dir_core [list #* _aside .git] + set unpublish [list\ + src/doc/*\ + src/doc/include/*\ + ] if {$opt_force} { - punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite ALL-TARGETS + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite ALL-TARGETS -unpublish_paths $unpublish] #file copy -force $layout_dir $projectdir } else { - punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core + set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite installedsourcechanged-targets -unpublish_paths $unpublish] + } + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + set sources_unchanged [dict get $resultdict sources_unchanged] + puts stdout "--------------------------" + flush stdout + puts stderr "Copied [llength $copied] files from $layout_dir to $projectdir" + foreach f $copied { + puts stdout "COPIED $f" + } + puts stdout "[llength $sources_unchanged] unchanged source files" + puts stdout "--------------------------" + } + set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite NO-TARGETS] + if {[dict size $resultdict]} { + set copied [dict get $resultdict files_copied] + set files_skipped [dict get $resultdict files_skipped] + puts stdout "--------------------------" + flush stdout + puts stderr "Copied [llength $copied] doc files from $layout_dir/src/doc to $projectdir/src/doc" + foreach f $copied { + puts stdout "COPIED $f" + } + puts stdout "[llength $files_skipped] skipped files" + puts stdout "--------------------------" } #lappend substfiles $projectdir/README.md @@ -260,8 +297,11 @@ namespace eval punk::mix::commandset::project { set fpath [file join $projectdir $templatetail] if {[file exists $fpath]} { set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd - set data [string map [list %project% $projectname] $data] - set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data; close $fdout + set data2 [string map [list %project% $projectname] $data] + if {$data2 ne $data} { + puts stdout "updated template file: $fpath" + set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout + } } else { puts stderr "warning: Missing template file $fpath" } @@ -273,7 +313,13 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force $opt_force + if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { + punk::mix::commandset::module::new $m -project $projectname -type $opt_type + } else { + if {$opt_force} { + punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 + } + } } } else { puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index c26cbf10..ba067039 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -247,9 +247,9 @@ namespace eval punk::mix::commandset::scriptwrap { - set template_folder_dict [punk::mix::base::lib::get_template_folders] + set template_base_dict [punk::mix::base::lib::get_template_basefolders] set tpldirs [list] - dict for {tdir tsourceinfo} $template_folder_dict { + dict for {tdir tsourceinfo} $template_base_dict { if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { lappend tpldirs $tdir } @@ -260,7 +260,7 @@ namespace eval punk::mix::commandset::scriptwrap { } else { if {![llength $tpldirs]} { set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" - append msg \n "Searched [dict size $template_folder_dict] template dirs" + append msg \n "Searched [dict size $template_base_dict] template dirs" error $msg } @@ -444,9 +444,9 @@ namespace eval punk::mix::commandset::scriptwrap { } } - set template_folder_dict [punk::mix::base::lib::get_template_folders] + set template_base_dict [punk::mix::base::lib::get_template_basefolders] set tpldirs [list] - dict for {tdir tsourceinfo} $template_folder_dict { + dict for {tdir tsourceinfo} $template_base_dict { if {[file exists $tdir/utility/scriptappwrappers]} { lappend tpldirs $tdir } diff --git a/src/modules/punk/mix/templates/.punkcheck b/src/modules/punk/mix/templates/.punkcheck new file mode 100644 index 00000000..d54e1f0b --- /dev/null +++ b/src/modules/punk/mix/templates/.punkcheck @@ -0,0 +1,84 @@ +INSTALLER -tsiso 2023-11-30T01:40:19 -ts 1701268819673094 -name make.tcl -keep_events 5 { + EVENT -tsiso_begin 2023-11-30T01:40:19 -ts_begin 1701268819676147 -tsiso_end {} -ts_end {} -id 250ad5e3-c95e-4833-addf-1282d09c9fec -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T01:47:15 -ts_begin 1701269235368667 -tsiso_end {} -ts_end {} -id 473193f2-54d2-44e8-a31a-9650c20177b5 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T01:53:57 -ts_begin 1701269637315528 -tsiso_end {} -ts_end {} -id 0984f805-501d-4f53-ba65-9fd68222a994 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T01:54:41 -ts_begin 1701269681466076 -tsiso_end {} -ts_end {} -id 94ea851c-85e5-4c48-b793-37b521ecb209 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T02:00:53 -ts_begin 1701270053672048 -tsiso_end {} -ts_end {} -id 1e060522-28a2-4712-a0f9-78ecc279c4d6 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T02:01:16 -ts_begin 1701270076820494 -tsiso_end {} -ts_end {} -id 5ce76b29-2b9a-4652-8c51-4f0281752381 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T02:06:29 -ts_begin 1701270389366390 -tsiso_end {} -ts_end {} -id 5271c70f-3a87-4a53-9c46-7b064b2bd43f -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-11-30T02:16:17 -ts_begin 1701270977456325 -tsiso_end {} -ts_end {} -id c84fbf6e-7aae-44b4-9f2b-d99615b76a81 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-05T04:22:54 -ts_begin 1701710574869059 -tsiso_end {} -ts_end {} -id 08ed1a89-fbb6-4cee-a543-e7b6f69663ae -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T01:45:19 -ts_begin 1701787519119661 -tsiso_end {} -ts_end {} -id 95cbdbe1-b100-4ed6-9202-3fa1dbbe7137 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T02:32:50 -ts_begin 1701790370423077 -tsiso_end {} -ts_end {} -id 9ba7b31c-9d08-4919-b475-3683fce42a37 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T03:36:28 -ts_begin 1701794188149001 -tsiso_end {} -ts_end {} -id 52ae56d6-8032-4855-88ee-5e71801b2846 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T05:31:47 -ts_begin 1701801107537126 -tsiso_end {} -ts_end {} -id 92f7f018-6b16-469e-9336-0d4a3b9bf75a -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T05:45:26 -ts_begin 1701801926154241 -tsiso_end {} -ts_end {} -id 9aa987b8-46d5-4059-9b5f-ba1fc8e9c841 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T05:55:36 -ts_begin 1701802536235596 -tsiso_end {} -ts_end {} -id 51123563-1b90-4437-b6e6-e85b1f8b9239 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T05:58:41 -ts_begin 1701802721245826 -tsiso_end {} -ts_end {} -id d67b0687-4760-4340-8022-0ffa2e69f2b2 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} + EVENT -tsiso_begin 2023-12-06T06:09:27 -ts_begin 1701803367522663 -tsiso_end {} -ts_end {} -id 35fd839e-2ef6-4391-b2ec-809149cbb0b2 -source ../../../.. -targets . -types {} -config {-make-step sync_templates} +} +FILEINFO -targets {} -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2 { + INSTALL-FAILED -tsiso 2023-11-30T01:40:19 -ts 1701268819677101 -installer make.tcl -eventid 250ad5e3-c95e-4833-addf-1282d09c9fec -metadata_us 21289 -ts_start_transfer 1701268819698390 -transfer_us 891 -elapsed_us 22180 { + SOURCE -type file -path ../../../../build.tcl -cksum 8ab5fbcfe246195a43a7ba884d3088dbced18640 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 9411 + } + INSTALL-FAILED -tsiso 2023-11-30T01:40:19 -ts 1701268819704081 -installer make.tcl -eventid 250ad5e3-c95e-4833-addf-1282d09c9fec -metadata_us 16366 -ts_start_transfer 1701268819720447 -transfer_us 705 -elapsed_us 17071 { + SOURCE -type file -path layouts/project/src/build.tcl -cksum 5f647ac1fbff3cb74f42a48bbef5239730a90054 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3516 + } + INSTALL-FAILED -tsiso 2023-11-30T01:40:19 -ts 1701268819725576 -installer make.tcl -eventid 250ad5e3-c95e-4833-addf-1282d09c9fec -metadata_us 21854 -ts_start_transfer 1701268819747430 -transfer_us 735 -elapsed_us 22589 { + SOURCE -type file -path ../../../../make.tcl -cksum 0e44e25f9127c61faeb1946e2f2c7adfc6cfa585 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 10241 + } + INSTALL-FAILED -tsiso 2023-11-30T01:40:19 -ts 1701268819752520 -installer make.tcl -eventid 250ad5e3-c95e-4833-addf-1282d09c9fec -metadata_us 18713 -ts_start_transfer 1701268819771233 -transfer_us 715 -elapsed_us 19428 { + SOURCE -type file -path layouts/project/src/make.tcl -cksum ca1412aac730e464406363d5fe90416cf66ce4a1 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 5116 + } +} +FILEINFO -targets layouts/project/src/build.tcl -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2 { + INSTALL-INPROGRESS -tsiso 2023-11-30T01:47:15 -ts 1701269235369501 -installer make.tcl -eventid 473193f2-54d2-44e8-a31a-9650c20177b5 -tempcontext {tag EVENT -tsiso_begin 2023-11-30T01:47:15 -ts_begin 1701269235368667 -tsiso_end {} -ts_end {} -id 473193f2-54d2-44e8-a31a-9650c20177b5 -source ../../../.. -targets . -types {} -config {-make-step sync_templates}} + INSTALL-INPROGRESS -tsiso 2023-11-30T01:53:57 -ts 1701269637316371 -installer make.tcl -eventid 0984f805-501d-4f53-ba65-9fd68222a994 -tempcontext {tag EVENT -tsiso_begin 2023-11-30T01:53:57 -ts_begin 1701269637315528 -tsiso_end {} -ts_end {} -id 0984f805-501d-4f53-ba65-9fd68222a994 -source ../../../.. -targets . -types {} -config {-make-step sync_templates}} + INSTALL-FAILED -tsiso 2023-11-30T01:54:41 -ts 1701269681466949 -installer make.tcl -eventid 94ea851c-85e5-4c48-b793-37b521ecb209 -metadata_us 23683 -ts_start_transfer 1701269681490632 -transfer_us 2738 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/buildx.tcl": no such file or directory} -elapsed_us 26421 { + SOURCE -type missing -path ../../../../buildx.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 8987 + } + INSTALL-FAILED -tsiso 2023-11-30T02:00:53 -ts 1701270053672988 -installer make.tcl -eventid 1e060522-28a2-4712-a0f9-78ecc279c4d6 -metadata_us 23887 -ts_start_transfer 1701270053696875 -transfer_us 2757 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/buildx.tcl": no such file or directory} -elapsed_us 26644 { + SOURCE -type missing -path ../../../../buildx.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 9065 + } + INSTALL-FAILED -tsiso 2023-11-30T02:01:16 -ts 1701270076821516 -installer make.tcl -eventid 5ce76b29-2b9a-4652-8c51-4f0281752381 -metadata_us 24281 -ts_start_transfer 1701270076845797 -transfer_us 2813 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/buildx.tcl": no such file or directory} -elapsed_us 27094 { + SOURCE -type missing -size {} -path ../../../../buildx.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 9039 + } + INSTALL-FAILED -tsiso 2023-11-30T02:06:29 -ts 1701270389367455 -installer make.tcl -eventid 5271c70f-3a87-4a53-9c46-7b064b2bd43f -metadata_us 24977 -ts_start_transfer 1701270389392432 -transfer_us 2918 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/buildx.tcl": no such file or directory} -elapsed_us 27895 { + SOURCE -type missing -size {} -path ../../../../buildx.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 9034 + } + INSTALL-RECORD -tsiso 2023-11-30T02:16:17 -ts 1701270977457421 -installer make.tcl -eventid c84fbf6e-7aae-44b4-9f2b-d99615b76a81 -metadata_us 26164 -ts_start_transfer 1701270977483585 -transfer_us 3773 -note test -elapsed_us 29937 { + SOURCE -type file -size 195 -path ../../../../build.tcl -cksum 8ab5fbcfe246195a43a7ba884d3088dbced18640 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 9681 + } + INSTALL-RECORD -tsiso 2023-12-05T04:22:54 -ts 1701710574870134 -installer make.tcl -eventid 08ed1a89-fbb6-4cee-a543-e7b6f69663ae -metadata_us 25456 -ts_start_transfer 1701710574895590 -transfer_us 4425 -note test -elapsed_us 29881 { + SOURCE -type file -size 196 -path ../../../../build.tcl -cksum 54fc5a072dc4627d1df737eecc8daed2fdd17f4d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 9776 + } + INSTALL-SKIPPED -tsiso 2023-12-06T06:09:27 -ts 1701803367523924 -installer make.tcl -eventid 35fd839e-2ef6-4391-b2ec-809149cbb0b2 -elapsed_us 22312 { + SOURCE -type file -size 196 -path ../../../../build.tcl -cksum 54fc5a072dc4627d1df737eecc8daed2fdd17f4d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 9830 + } +} +FILEINFO -targets layouts/project/src/make.tcl -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2 { + INSTALL-FAILED -tsiso 2023-11-30T01:54:41 -ts 1701269681498040 -installer make.tcl -eventid 94ea851c-85e5-4c48-b793-37b521ecb209 -metadata_us 23162 -ts_start_transfer 1701269681521202 -transfer_us 2474 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/makex.tcl": no such file or directory} -elapsed_us 25636 { + SOURCE -type missing -path ../../../../makex.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 8978 + } + INSTALL-FAILED -tsiso 2023-11-30T02:00:53 -ts 1701270053704394 -installer make.tcl -eventid 1e060522-28a2-4712-a0f9-78ecc279c4d6 -metadata_us 23411 -ts_start_transfer 1701270053727805 -transfer_us 2522 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/makex.tcl": no such file or directory} -elapsed_us 25933 { + SOURCE -type missing -path ../../../../makex.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 9024 + } + INSTALL-FAILED -tsiso 2023-11-30T02:01:16 -ts 1701270076853426 -installer make.tcl -eventid 5ce76b29-2b9a-4652-8c51-4f0281752381 -metadata_us 23643 -ts_start_transfer 1701270076877069 -transfer_us 2566 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/makex.tcl": no such file or directory} -elapsed_us 26209 { + SOURCE -type missing -size {} -path ../../../../makex.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 8991 + } + INSTALL-FAILED -tsiso 2023-11-30T02:06:29 -ts 1701270389400265 -installer make.tcl -eventid 5271c70f-3a87-4a53-9c46-7b064b2bd43f -metadata_us 23863 -ts_start_transfer 1701270389424128 -transfer_us 2604 -note {copy failed with err: error copying "C:/repo/jn/shellspy/src/makex.tcl": no such file or directory} -elapsed_us 26467 { + SOURCE -type missing -size {} -path ../../../../makex.tcl -cksum -cksum_all_opts {-cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1} -changed 1 -metadata_us 9005 + } + INSTALL-RECORD -tsiso 2023-12-06T01:45:19 -ts 1701787519148901 -installer make.tcl -eventid 95cbdbe1-b100-4ed6-9202-3fa1dbbe7137 -metadata_us 26024 -ts_start_transfer 1701787519174925 -transfer_us 4325 -note test -elapsed_us 30349 { + SOURCE -type file -size 32642 -path ../../../../make.tcl -cksum 80105c381fa3db05833f44b716c1536fef128d84 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 10482 + } + INSTALL-RECORD -tsiso 2023-12-06T02:32:50 -ts 1701790370452196 -installer make.tcl -eventid 9ba7b31c-9d08-4919-b475-3683fce42a37 -metadata_us 26602 -ts_start_transfer 1701790370478798 -transfer_us 4392 -note test -elapsed_us 30994 { + SOURCE -type file -size 32922 -path ../../../../make.tcl -cksum 7aea3c018ce954a67ce8254c88e07407e008247c -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 10680 + } + INSTALL-RECORD -tsiso 2023-12-06T03:36:28 -ts 1701794188178099 -installer make.tcl -eventid 52ae56d6-8032-4855-88ee-5e71801b2846 -metadata_us 26790 -ts_start_transfer 1701794188204889 -transfer_us 4285 -note test -elapsed_us 31075 { + SOURCE -type file -size 32956 -path ../../../../make.tcl -cksum dda7ebdcf186a5bd8e7f9c72a8e2bc892620fcab -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 11017 + } + INSTALL-SKIPPED -tsiso 2023-12-06T06:09:27 -ts 1701803367551725 -installer make.tcl -eventid 35fd839e-2ef6-4391-b2ec-809149cbb0b2 -elapsed_us 22232 { + SOURCE -type file -size 32956 -path ../../../../make.tcl -cksum dda7ebdcf186a5bd8e7f9c72a8e2bc892620fcab -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 10590 + } +} \ No newline at end of file diff --git a/src/modules/punk/mix/templates/layouts/project/.gitignore b/src/modules/punk/mix/templates/layouts/project/.gitignore index deddaf71..4d6b6912 100644 --- a/src/modules/punk/mix/templates/layouts/project/.gitignore +++ b/src/modules/punk/mix/templates/layouts/project/.gitignore @@ -37,3 +37,11 @@ _FOSSIL_ todo.txt + +zig-cache/ +zig-out/ +/release/ +/debug/ +/build/ +/build-*/ +/docgen_tmp/ diff --git a/src/modules/punk/mix/templates/layouts/project/src/_vfscommon/lib/common_vfs_libs b/src/modules/punk/mix/templates/layouts/project/src/_vfscommon/lib/common_vfs_libs new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/http-2.10b1.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/http-2.10b1.tm new file mode 100644 index 00000000..6c3c068c --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/http-2.10b1.tm @@ -0,0 +1,5457 @@ +# http.tcl -- +# +# Client-side HTTP for GET, POST, and HEAD commands. These routines can +# be used in untrusted code that uses the Safesock security policy. +# These procedures use a callback interface to avoid using vwait, which +# is not defined in the safe base. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +# Keep this in sync with pkgIndex.tcl and with the install directories in +# Makefiles +package provide http 2.10b1 + +namespace eval http { + # Allow resourcing to not clobber existing data + + variable http + if {![info exists http]} { + array set http { + -accept */* + -cookiejar {} + -pipeline 1 + -postfresh 0 + -proxyhost {} + -proxyport {} + -proxyfilter http::ProxyRequired + -proxynot {} + -proxyauth {} + -repost 0 + -threadlevel 0 + -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 + # 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]} { + set http(-useragent) "Mozilla/5.0\ + (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]" + } + } + + proc init {} { + # Set up the map for quoting chars. RFC3986 Section 2.3 say percent + # encode all except: "... percent-encoded octets in the ranges of + # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period + # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI + # producers ..." + for {set i 0} {$i <= 256} {incr i} { + set c [format %c $i] + if {![string match {[-._~a-zA-Z0-9]} $c]} { + set map($c) %[format %.2X $i] + } + } + # These are handled specially + set map(\n) %0D%0A + variable formMap [array get map] + + # Create a map for HTTP/1.1 open sockets + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + if {[info exists socketMapping]} { + # Close open sockets on re-init. Do not permit retries. + foreach {url sock} [array get socketMapping] { + unset -nocomplain socketClosing($url) + unset -nocomplain socketPlayCmd($url) + CloseSocket $sock + } + } + + # 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 + array unset socketRdQueue + array unset socketWrQueue + array unset socketPhQueue + array unset socketClosing + array unset socketPlayCmd + array unset socketCoEvent + array unset socketProxyId + array set socketMapping {} + array set socketRdState {} + array set socketWrState {} + array set socketRdQueue {} + array set socketWrQueue {} + array set socketPhQueue {} + array set socketClosing {} + array set socketPlayCmd {} + array set socketCoEvent {} + array set socketProxyId {} + return + } + init + + variable urlTypes + if {![info exists urlTypes]} { + set urlTypes(http) [list 80 ::http::socket] + } + + variable encodings [string tolower [encoding names]] + # This can be changed, but iso8859-1 is the RFC standard. + variable defaultCharset + if {![info exists defaultCharset]} { + set defaultCharset "iso8859-1" + } + + # Force RFC 3986 strictness in geturl url verification? + variable strict + if {![info exists strict]} { + set strict 1 + } + + # Let user control default keepalive for compatibility + variable defaultKeepalive + if {![info exists defaultKeepalive]} { + set defaultKeepalive 0 + } + + # Regular expression used to parse cookies + variable CookieRE {(?x) # EXPANDED SYNTAX + \s* # Ignore leading spaces + ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name + = # LITERAL: Equal sign + ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value + (?: + \s* ; \s* # LITERAL: semicolon + ([^\u0000]+) # Match the options + )? + } + + variable TmpSockCounter 0 + variable ThreadCounter 0 + + variable reasonDict [dict create {*}{ + 100 Continue + 101 {Switching Protocols} + 102 Processing + 103 {Early Hints} + 200 OK + 201 Created + 202 Accepted + 203 {Non-Authoritative Information} + 204 {No Content} + 205 {Reset Content} + 206 {Partial Content} + 207 Multi-Status + 208 {Already Reported} + 226 {IM Used} + 300 {Multiple Choices} + 301 {Moved Permanently} + 302 Found + 303 {See Other} + 304 {Not Modified} + 305 {Use Proxy} + 306 (Unused) + 307 {Temporary Redirect} + 308 {Permanent Redirect} + 400 {Bad Request} + 401 Unauthorized + 402 {Payment Required} + 403 Forbidden + 404 {Not Found} + 405 {Method Not Allowed} + 406 {Not Acceptable} + 407 {Proxy Authentication Required} + 408 {Request Timeout} + 409 Conflict + 410 Gone + 411 {Length Required} + 412 {Precondition Failed} + 413 {Content Too Large} + 414 {URI Too Long} + 415 {Unsupported Media Type} + 416 {Range Not Satisfiable} + 417 {Expectation Failed} + 418 (Unused) + 421 {Misdirected Request} + 422 {Unprocessable Content} + 423 Locked + 424 {Failed Dependency} + 425 {Too Early} + 426 {Upgrade Required} + 428 {Precondition Required} + 429 {Too Many Requests} + 431 {Request Header Fields Too Large} + 451 {Unavailable For Legal Reasons} + 500 {Internal Server Error} + 501 {Not Implemented} + 502 {Bad Gateway} + 503 {Service Unavailable} + 504 {Gateway Timeout} + 505 {HTTP Version Not Supported} + 506 {Variant Also Negotiates} + 507 {Insufficient Storage} + 508 {Loop Detected} + 510 {Not Extended (OBSOLETED)} + 511 {Network Authentication Required} + }] + + variable failedProxyValues { + binary + body + charset + coding + connection + connectionRespFlag + currentsize + host + http + httpResponse + meta + method + querylength + queryoffset + reasonPhrase + requestHeaders + requestLine + responseCode + state + status + tid + totalsize + transfer + type + } + + namespace export geturl config reset wait formatQuery postError quoteString + namespace export register unregister registerError + namespace export requestLine requestHeaders requestHeaderValue + namespace export responseLine responseHeaders responseHeaderValue + namespace export responseCode responseBody responseInfo reasonPhrase + # - Legacy aliases, were never exported: + # data, code, mapReply, meta, ncode + # - Callable from outside (e.g. from TLS) by fully-qualified name, but + # not exported: + # socket + # - Useful, but never exported (and likely to have naming collisions): + # size, status, cleanup, error, init + # Comments suggest that "init" can be used for re-initialisation, + # although the command is undocumented. + # - Never exported, renamed from lower-case names: + # GetTextLine, MakeTransformationChunked. +} + +# http::Log -- +# +# Debugging output -- define this to observe HTTP/1.1 socket usage. +# Should echo any args received. +# +# Arguments: +# msg Message to output +# +if {[info command http::Log] eq {}} {proc http::Log {args} {}} + +# http::register -- +# +# See documentation for details. +# +# Arguments: +# proto URL protocol prefix, e.g. https +# port Default port for protocol +# command Command to use to create socket +# Results: +# list of port and command that was registered. + +proc http::register {proto port command} { + variable urlTypes + set urlTypes([string tolower $proto]) [list $port $command] +} + +# http::unregister -- +# +# Unregisters URL protocol handler +# +# Arguments: +# proto URL protocol prefix, e.g. https +# Results: +# list of port and command that was unregistered. + +proc http::unregister {proto} { + variable urlTypes + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + return -code error "unsupported url type \"$proto\"" + } + set old $urlTypes($lower) + unset urlTypes($lower) + return $old +} + +# http::config -- +# +# See documentation for details. +# +# Arguments: +# args Options parsed by the procedure. +# Results: +# TODO + +proc http::config {args} { + variable http + set options [lsort [array names http -*]] + set usage [join $options ", "] + if {[llength $args] == 0} { + set result {} + foreach name $options { + lappend result $name $http($name) + } + return $result + } + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + if {[llength $args] == 1} { + set flag [lindex $args 0] + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + return $http($flag) + } elseif {[llength $args] % 2} { + return -code error "If more than one argument is supplied, the\ + number of arguments must be even" + } else { + foreach {flag value} $args { + if {![regexp -- $pat $flag]} { + return -code error "Unknown option $flag, must be: $usage" + } + if {($flag eq {-threadlevel}) && ($value ni {0 1 2})} { + return -code error {Option -threadlevel must be 0, 1 or 2} + } + set http($flag) $value + } + return + } +} + +# ------------------------------------------------------------------------------ +# Proc http::reasonPhrase +# ------------------------------------------------------------------------------ +# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code. +# Information obtained from: +# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml +# +# Arguments: +# code - A valid HTTP Status Code (integer from 100 to 599) +# +# Return Value: the reason phrase +# ------------------------------------------------------------------------------ + +proc http::reasonPhrase {code} { + variable reasonDict + if {![regexp -- {^[1-5][0-9][0-9]$} $code]} { + set msg {argument must be a three-digit integer from 100 to 599} + return -code error $msg + } + if {[dict exists $reasonDict $code]} { + set reason [dict get $reasonDict $code] + } else { + set reason Unassigned + } + return $reason +} + +# http::Finish -- +# +# Clean up the socket and eval close time callbacks +# +# Arguments: +# token Connection token. +# errormsg (optional) If set, forces status to error. +# 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. +# +# Side Effects: +# May close the socket. + +proc http::Finish {token {errormsg ""} {skipCB 0}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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" + } + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) + } + + # Is this an upgrade request/response? + set upgradeResponse \ + [expr { [info exists state(upgradeRequest)] + && $state(upgradeRequest) + && [info exists state(http)] + && ([ncode $token] eq {101}) + && [info exists state(connection)] + && ("upgrade" in $state(connection)) + && [info exists state(upgrade)] + && ("" ne $state(upgrade)) + }] + + if { ($state(status) eq "timeout") + || ($state(status) eq "error") + || ($state(status) eq "eof") + } { + set closeQueue 1 + set connId $state(socketinfo) + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } + if {$state(tid) ne {}} { + # When opening the socket in a thread, and calling http::reset + # immediately, the thread may still exist. + # Test http-4.11 may come here. + thread::release $state(tid) + set state(tid) {} + } else { + } + } elseif {$upgradeResponse} { + # Special handling for an upgrade request/response. + # - geturl ensures that this is not a "persistent" socket used for + # multiple HTTP requests, so a call to KeepSocket is not needed. + # - Leave socket open, so a call to CloseSocket is not needed either. + # - Remove fileevent bindings. The caller will set its own bindings. + # - THE CALLER MUST PROCESS THE UPGRADED SOCKET IN THE CALLBACK COMMAND + # PASSED TO http::geturl AS -command callback. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + } elseif { + ([info exists state(-keepalive)] && !$state(-keepalive)) + || ([info exists state(connection)] && ("close" in $state(connection))) + } { + set closeQueue 1 + set connId $state(socketinfo) + if {[info exists state(sock)]} { + set sock $state(sock) + CloseSocket $state(sock) $token + } else { + # When opening the socket and calling http::reset + # immediately, the socket may not yet exist. + # Test http-4.11 may come here. + } + } elseif { + ([info exists state(-keepalive)] && $state(-keepalive)) + && ([info exists state(connection)] && ("close" ni $state(connection))) + } { + KeepSocket $token + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state(-command)] && (!$skipCB) + && (![info exists state(done-command-cb)])} { + set state(done-command-cb) yes + if { [catch {namespace eval :: $state(-command) $token} err] + && ($errormsg eq "") + } { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + + if { $closeQueue + && [info exists socketMapping($connId)] + && ($socketMapping($connId) eq $sock) + } { + http::CloseQueuedQueries $connId $token + # This calls Unset. Other cases do not need the call. + } + 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. +# +# If $socketClosing(*), then ("close" in $state(connection)) and therefore +# this command will not be called by Finish. +# +# Arguments: +# token Connection token. + +proc http::KeepSocket {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 {}} + } + + 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] + + #Log pipelined, GRANT read access to $token3 in KeepSocket + set socketRdState($connId) $token3 + ReceiveResponse $token3 + + # 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. + set conn [set ${token3}(connArgs)] + #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. + set conn [set ${token3}(connArgs)] + #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)] + && ("close" ni $state(connection)) + } { + # 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] + set conn [set ${token3}(connArgs)] + #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 { + CloseSocket $state(sock) $token + # There is no socketMapping($state(socketinfo)), so it does not matter + # that CloseQueuedQueries is not called. + } + 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 +} + +# http::CloseSocket - +# +# 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 "else" block of the first "if" command. + +proc http::CloseSocket {s {token {}}} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set tk [namespace tail $token] + + catch {fileevent $s readable {}} + set connId {} + if {$token ne ""} { + variable $token + upvar 0 $token state + if {[info exists state(socketinfo)]} { + set connId $state(socketinfo) + } + } else { + set map [array get socketMapping] + set ndx [lsearch -exact $map $s] + if {$ndx >= 0} { + incr ndx -1 + set connId [lindex $map $ndx] + } + } + 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 + } 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 socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + ##Log CloseQueuedQueries $connId $token + 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 { + set tk [namespace tail $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". + # - At this stage socketPhQueue is empty. + set unfinished $socketPlayCmd($connId) + set socketRdQueue($connId) {} + set socketWrQueue($connId) {} + } else { + set unfinished {} + } + + Unset $connId + + if {$unfinished ne {}} { + Log ^R$tk Any unfinished transactions (excluding $token) failed \ + - token $token - unfinished $unfinished + {*}$unfinished + # Calls ReplayIfClose. + } + 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 socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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) + unset -nocomplain socketProxyId($connId) + return +} + +# http::reset -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# why Status info. +# +# Side Effects: +# See Finish + +proc http::reset {token {why reset}} { + variable $token + upvar 0 $token state + set state(status) $why + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + Finish $token + if {[info exists state(error)]} { + set errorlist $state(error) + unset state + eval ::error $errorlist + # i.e. error msg errorInfo errorCode + } + return +} + +# http::geturl -- +# +# Establishes a connection to a remote url via http. +# +# Arguments: +# 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 +# array that the caller should unset to garbage collect the state. + +proc http::geturl {url args} { + variable urlTypes + + # - If ::tls::socketCmd has its default value "::socket", change it to the + # new value ::http::socketForTls. + # - If the old value is different, then it has been modified either by the + # script or by the Tcl installation, and replaced by a new command. The + # script or installation that modified ::tls::socketCmd is also + # responsible for integrating ::http::socketForTls into its own "new" + # command, if it wishes to do so. + # - Commands that open a socket: + # - ::socket - basic + # - ::http::socket - can use a thread to avoid blockage by slow DNS + # lookup. See http::config option -threadlevel. + # - ::http::socketForTls - as ::http::socket, but can also open a socket + # for HTTPS/TLS through a proxy. + + if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} { + set ::tls::socketCmd ::http::socketForTls + } + + set token [CreateToken $url {*}$args] + variable $token + upvar 0 $token state + + AsyncTransaction $token + + # -------------------------------------------------------------------------- + # Synchronous Call to http::geturl + # -------------------------------------------------------------------------- + # - If the call to http::geturl is asynchronous, it is now complete (apart + # from delivering the return value). + # - If the call to http::geturl is synchronous, the command must now wait + # for the HTTP transaction to be completed. The call to http::wait uses + # vwait, which may be inappropriate if the caller makes other HTTP + # requests in the background. + # -------------------------------------------------------------------------- + + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. + http::wait $token + + if {![info exists state]} { + # If we timed out then Finish has been called and the users + # command callback may have cleaned up the token. If so we end up + # here with nothing left to do. + return $token + } elseif {$state(status) eq "error"} { + # 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. + set err [lindex $state(error) 0] + cleanup $token + return -code error $err + } + } + + return $token +} + +# ------------------------------------------------------------------------------ +# Proc http::CreateToken +# ------------------------------------------------------------------------------ +# Command to convert arguments into an initialised request token. +# The return value is the variable name of the token. +# +# Other effects: +# - Sets ::http::http(usingThread) if not already done +# - Sets ::http::http(uid) if not already done +# - Increments ::http::http(uid) +# - May increment ::http::TmpSockCounter +# - Alters ::http::socketPlayCmd, ::http::socketWrQueue if a -keepalive 1 +# request is appended to the queue of a persistent socket that is already +# scheduled to close. +# This also sets state(alreadyQueued) to 1. +# - Alters ::http::socketPhQueue if a -keepalive 1 request is appended to the +# queue of a persistent socket that has not yet been created (and is therefore +# represented by a placeholder). +# This also sets state(ReusingPlaceholder) to 1. +# ------------------------------------------------------------------------------ + +proc http::CreateToken {url args} { + variable http + variable urlTypes + variable defaultCharset + variable defaultKeepalive + variable strict + variable TmpSockCounter + + # Initialize the state variable, an array. We'll return the name of this + # array as the token for the transaction. + + if {![info exists http(usingThread)]} { + set http(usingThread) 0 + } + if {![info exists http(uid)]} { + 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. + + array set state { + -binary false + -blocksize 8192 + -queryblocksize 8192 + -validate 0 + -headers {} + -timeout 0 + -type application/x-www-form-urlencoded + -queryprogress {} + -protocol 1.1 + -guesstype 0 + binary 0 + state created + meta {} + method {} + coding {} + currentsize 0 + totalsize 0 + querylength 0 + queryoffset 0 + type application/octet-stream + body {} + status "" + http "" + httpResponse {} + responseCode {} + reasonPhrase {} + connection keep-alive + tid {} + requestHeaders {} + requestLine {} + transfer {} + proxyUsed none + } + set state(-keepalive) $defaultKeepalive + set state(-strict) $strict + # These flags have their types verified [Bug 811170] + array set type { + -binary boolean + -blocksize integer + -guesstype boolean + -queryblocksize integer + -strict boolean + -timeout integer + -validate boolean + -headers list + } + set state(charset) $defaultCharset + set options { + -binary -blocksize -channel -command -guesstype -handler -headers -keepalive + -method -myaddr -progress -protocol -query -queryblocksize + -querychannel -queryprogress -strict -timeout -type -validate + } + set usage [join [lsort $options] ", "] + set options [string map {- ""} $options] + set pat ^-(?:[join $options |])$ + foreach {flag value} $args { + if {[regexp -- $pat $flag]} { + # Validate numbers + if { [info exists type($flag)] + && (![string is $type($flag) -strict $value]) + } { + unset $token + return -code error \ + "Bad value for $flag ($value), must be $type($flag)" + } + if {($flag eq "-headers") && ([llength $value] % 2 != 0)} { + unset $token + return -code error "Bad value for $flag ($value), number\ + of list elements must be even" + } + set state($flag) $value + } else { + unset $token + return -code error "Unknown option $flag, can be: $usage" + } + } + + # Make sure -query and -querychannel aren't both specified + + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + if {$isQuery && $isQueryChannel} { + unset $token + return -code error "Can't combine -query and -querychannel options!" + } + + # Validate URL, determine the server host and port, and check proxy case + # Recognize user:pass@host URLs also, although we do not do anything with + # that info yet. + + # URLs have basically four parts. + # First, before the colon, is the protocol scheme (e.g. http) + # Second, for HTTP-like protocols, is the authority + # The authority is preceded by // and lasts up to (but not including) + # the following / or ? and it identifies up to four parts, of which + # only one, the host, is required (if an authority is present at all). + # All other parts of the authority (user name, password, port number) + # are optional. + # Third is the resource name, which is split into two parts at a ? + # The first part (from the single "/" up to "?") is the path, and the + # second part (from that "?" up to "#") is the query. *HOWEVER*, we do + # not need to separate them; we send the whole lot to the server. + # Both, path and query are allowed to be missing, including their + # delimiting character. + # Fourth is the fragment identifier, which is everything after the first + # "#" in the URL. The fragment identifier MUST NOT be sent to the server + # and indeed, we don't bother to validate it (it could be an error to + # pass it in here, but it's cheap to strip). + # + # An example of a URL that has all the parts: + # + # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes + # + # The "http" is the protocol, the user is "jschmoe", the password is + # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is + # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". + # + # Note that the RE actually combines the user and password parts, as + # recommended in RFC 3986. Indeed, that RFC states that putting passwords + # in URLs is a Really Bad Idea, something with which I would agree utterly. + # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format + # "user:password@". It is retained here for backward compatibility, + # but its use is not recommended. + # + # From a validation perspective, we need to ensure that the parts of the + # URL that are going to the server are correctly encoded. This is only + # done if $state(-strict) is true (inherited from $::http::strict). + + set URLmatcher {(?x) # this is _expanded_ syntax + ^ + (?: (\w+) : ) ? # + (?: // + (?: + ( + [^@/\#?]+ # + ) @ + )? + ( # + [^/:\#?]+ | # host name or IPv4 address + \[ [^/\#?]+ \] # IPv6 address in square brackets + ) + (?: : (\d+) )? # + )? + ( [/\?] [^\#]*)? # (including query) + (?: \# (.*) )? # + $ + } + + # Phase one: parse + if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { + unset $token + return -code error "Unsupported URL: $url" + } + # Phase two: validate + set host [string trim $host {[]}]; # strip square brackets from IPv6 address + if {$host eq ""} { + # Caller has to provide a host name; we do not have a "default host" + # that would enable us to handle relative URLs. + unset $token + return -code error "Missing host part: $url" + # Note that we don't check the hostname for validity here; if it's + # invalid, we'll simply fail to resolve it later on. + } + if {$port ne "" && $port > 65535} { + unset $token + return -code error "Invalid port number: $port" + } + # The user identification and resource identification parts of the URL can + # have encoded characters in them; take care! + if {$user ne ""} { + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ + $ + } + if {$state(-strict) && ![regexp -- $validityRE $user]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL user" + } + return -code error "Illegal characters in URL user" + } + } + if {$srvurl ne ""} { + # RFC 3986 allows empty paths (not even a /), but servers + # return 400 if the path in the HTTP request doesn't start + # with / , so add it here if needed. + if {[string index $srvurl 0] ne "/"} { + set srvurl /$srvurl + } + # Check for validity according to RFC 3986, Appendix A + set validityRE {(?xi) + ^ + # Path part (already must start with / character) + (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* + # Query part (optional, permits ? characters) + (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? + $ + } + if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { + unset $token + # Provide a better error message in this error case + if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { + return -code error \ + "Illegal encoding character usage \"$bad\" in URL path" + } + return -code error "Illegal characters in URL path" + } + if {![regexp {^[^?#]+} $srvurl state(path)]} { + set state(path) / + } + } else { + set srvurl / + set state(path) / + } + if {$proto eq ""} { + set proto http + } + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { + unset $token + return -code error "Unsupported URL type \"$proto\"" + } + set defport [lindex $urlTypes($lower) 0] + set defcmd [lindex $urlTypes($lower) 1] + + if {$port eq ""} { + set port $defport + } + if {![catch {$http(-proxyfilter) $host} proxy]} { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } else { + set phost {} + set pport {} + } + + # OK, now reassemble into a full URL + set url ${proto}:// + if {$user ne ""} { + append url $user + append url @ + } + append url $host + if {$port != $defport} { + append url : $port + } + append url $srvurl + # Don't append the fragment! RFC 7230 Sec 5.1 + set state(url) $url + + # Proxy connections aren't shared among different hosts. + set state(socketinfo) $host:$port + + # Save the accept types at this point to prevent a race condition. [Bug + # c11a51c482] + set state(accept-types) $http(-accept) + + # Check whether this is an Upgrade request. + set connectionValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Connection]] + set connectionValues [string tolower $connectionValues] + set upgradeValues [SplitCommaSeparatedFieldValue \ + [GetFieldValue $state(-headers) Upgrade]] + set state(upgradeRequest) [expr { "upgrade" in $connectionValues + && [llength $upgradeValues] >= 1}] + set state(connectionValues) $connectionValues + + 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 + } + } elseif {$state(upgradeRequest)} { + # It's an upgrade request. Method must be GET (untested). + # Force -keepalive to 0 so the connection is not made over a persistent + # socket, i.e. one used for multiple HTTP requests. + set state(-keepalive) 0 + } else { + # It's a non-upgrade GET or HEAD. + set state(-pipeline) $http(-pipeline) + } + + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + + # RFC 7320 A.1 - HTTP/1.0 Keep-Alive is problematic. We do not support it. + if {$state(-protocol) eq "1.0"} { + set state(connection) close + set state(-keepalive) 0 + } + + # Handle proxy requests here for http:// but not for https:// + # The proxying for https is done in the ::http::socketForTls command. + # A proxy request for http:// needs the full URL in the HTTP request line, + # including the server name. + # The *tls* test below attempts to describe protocols in addition to + # "https on port 443" that use HTTP over TLS. + if {($phost ne "") && (![string match -nocase *tls* $defcmd])} { + set srvurl $url + set targetAddr [list $phost $pport] + set state(proxyUsed) HttpProxy + # The value of state(proxyUsed) none|HttpProxy depends only on the + # all-transactions http::config settings and on the target URL. + # Even if this is a persistent socket there is no need to change the + # value of state(proxyUsed) for other transactions that use the socket: + # they have the same value already. + } else { + set targetAddr [list $host $port] + } + + set sockopts [list -async] + + # Pass -myaddr directly to the socket command + if {[info exists state(-myaddr)]} { + lappend sockopts -myaddr $state(-myaddr) + } + + set state(connArgs) [list $proto $phost $srvurl] + set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr] + + # 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 state(alreadyQueued) 0 + set state(ReusingPlaceholder) 0 + if {$state(-keepalive)} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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. + + if { [info exists socketClosing($state(socketinfo))] + && $socketClosing($state(socketinfo)) + } { + # 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)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) + Log "reusing closing socket $sock for $state(socketinfo) - token $token" + + set state(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 + ##Log socketPlayCmd($state(socketinfo)) is $socketPlayCmd($state(socketinfo)) + ##Log socketWrQueue($state(socketinfo)) is $socketWrQueue($state(socketinfo)) + } elseif { + [catch {fconfigure $socketMapping($state(socketinfo))}] + && (![SockIsPlaceHolder $socketMapping($state(socketinfo))]) + } { + ###Log "Socket $socketMapping($state(socketinfo)) for $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 + # 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. + # - The socket may not yet exist, and be defined with a placeholder. + set reusing 1 + set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) + if {[SockIsPlaceHolder $sock]} { + set state(ReusingPlaceholder) 1 + lappend socketPhQueue($sock) $token + } else { + } + Log "reusing open socket $sock for $state(socketinfo) - token $token" + } + # Do not automatically close the connection socket. + set state(connection) keep-alive + } + } + + set state(reusing) $reusing + unset reusing + + if {![info exists sock]} { + # N.B. At this point ([info exists sock] == $state(reusing)). + # This will no longer be true after we set a value of sock here. + # Give the socket a placeholder name. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + } + set state(sock) $sock + + if {$state(reusing)} { + # Define these for use (only) by http::ReplayIfDead if the persistent + # connection has died. + set state(tmpConnArgs) $state(connArgs) + set state(tmpState) [array get state] + set state(tmpOpenCmd) $state(openCmd) + } + return $token +} + + +# ------------------------------------------------------------------------------ +# Proc ::http::SockIsPlaceHolder +# ------------------------------------------------------------------------------ +# Command to return 0 if the argument is a genuine socket handle, or 1 if is a +# placeholder value generated by geturl or ReplayCore before the real socket is +# created. +# +# Arguments: +# sock - either a valid socket handle or a placeholder value +# +# Return Value: 0 or 1 +# ------------------------------------------------------------------------------ + +proc http::SockIsPlaceHolder {sock} { + expr {[string range $sock 0 16] eq {HTTP_PLACEHOLDER_}} +} + + +# ------------------------------------------------------------------------------ +# state(reusing) +# ------------------------------------------------------------------------------ +# - state(reusing) is set by geturl, ReplayCore +# - state(reusing) is used by geturl, AsyncTransaction, OpenSocket, +# ConfigureNewSocket, and ScheduleRequest when creating and configuring the +# connection. +# - state(reusing) is used by Connect, Connected, Event x 2 when deciding +# whether to call TestForReplay. +# - Other places 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. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::AsyncTransaction +# ------------------------------------------------------------------------------ +# This command is called by geturl and ReplayCore to prepare the HTTP +# transaction prescribed by a suitably prepared token. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::AsyncTransaction {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set sock $state(sock) + + # 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 { $state(-keepalive) + && (![info exists socketMapping($state(socketinfo))]) + } { + # This code is executed only for the first -keepalive request on a + # socket. It makes the socket persistent. + ##Log " PreparePersistentConnection" $token -- $sock -- DO + set DoLater [PreparePersistentConnection $token] + } else { + ##Log " PreparePersistentConnection" $token -- $sock -- SKIP + set DoLater {-traceread 0 -tracewrite 0} + } + + if {$state(ReusingPlaceholder)} { + # - This request was added to the socketPhQueue of a persistent + # connection. + # - But the connection has not yet been created and is a placeholder; + # - And the placeholder was created by an earlier request. + # - When that earlier request calls OpenSocket, its placeholder is + # replaced with a true socket, and it then executes the equivalent of + # OpenSocket for any subsequent requests that have + # $state(ReusingPlaceholder). + Log >J$tk after idle coro NO - ReusingPlaceholder + } elseif {$state(alreadyQueued)} { + # - This request was added to the socketWrQueue and socketPlayCmd + # of a persistent connection that will close at the end of its current + # read operation. + Log >J$tk after idle coro NO - alreadyQueued + } else { + Log >J$tk after idle coro YES + set CoroName ${token}--SocketCoroutine + set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \ + $token $DoLater]] + dict set socketCoEvent($state(socketinfo)) $token $cancel + set state(socketcoro) $cancel + } + + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::PreparePersistentConnection +# ------------------------------------------------------------------------------ +# This command is called by AsyncTransaction to initialise a "persistent +# connection" based upon a socket placeholder. It is called the first time the +# socket is associated with a "-keepalive" request. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: - DoLater, a dictionary of boolean values listing unfinished +# tasks; to be passed to ConfigureNewSocket via OpenSocket. +# ------------------------------------------------------------------------------ + +proc http::PreparePersistentConnection {token} { + variable $token + upvar 0 $token state + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set DoLater {-traceread 0 -tracewrite 0} + set socketMapping($state(socketinfo)) $state(sock) + set socketProxyId($state(socketinfo)) $state(proxyUsed) + # - The value of state(proxyUsed) was set in http::CreateToken to either + # "none" or "HttpProxy". + # - $token is the first transaction to use this placeholder, so there are + # no other tokens whose (proxyUsed) must be modified. + + if {![info exists socketRdState($state(socketinfo))]} { + set socketRdState($state(socketinfo)) {} + # set varName ::http::socketRdState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelReadPipeline + dict set DoLater -traceread 1 + } + if {![info exists socketWrState($state(socketinfo))]} { + set socketWrState($state(socketinfo)) {} + # set varName ::http::socketWrState($state(socketinfo)) + # trace add variable $varName unset ::http::CancelWritePipeline + dict set DoLater -tracewrite 1 + } + + 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 + } + + # Value of socketPhQueue() may have already been set by ReplayCore. + if {![info exists socketPhQueue($state(sock))]} { + set socketPhQueue($state(sock)) {} + } + set socketRdQueue($state(socketinfo)) {} + set socketWrQueue($state(socketinfo)) {} + set socketClosing($state(socketinfo)) 0 + set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} + set socketCoEvent($state(socketinfo)) {} + set socketProxyId($state(socketinfo)) {} + + return $DoLater +} + +# ------------------------------------------------------------------------------ +# Proc ::http::OpenSocket +# ------------------------------------------------------------------------------ +# This command is called as a coroutine idletask to start the asynchronous HTTP +# transaction in most cases. For the exceptions, see the calling code in +# command AsyncTransaction. +# +# Arguments: +# token - connection token (name of an array) +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::OpenSocket {token DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + Log >K$tk Start OpenSocket coroutine + + if {![info exists state(-keepalive)]} { + # The request has already been cancelled by the calling script. + return + } + + set sockOld $state(sock) + + dict unset socketCoEvent($state(socketinfo)) $token + unset -nocomplain state(socketcoro) + + if {[catch { + if {$state(reusing)} { + # If ($state(reusing)) is true, then we do not need to create a new + # socket, even if $sockOld is only a placeholder for a socket. + set sock $sockOld + } else { + # set sock in the [catch] below. + set pre [clock milliseconds] + ##Log pre socket opened, - token $token + ##Log $state(openCmd) - token $token + set sock [namespace eval :: $state(openCmd)] + set state(sock) $sock + # Normal return from $state(openCmd) always returns a valid socket. + # A TLS proxy connection with 407 or other failure from the + # proxy server raises an error. + + # Initialisation of a new socket. + ##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) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + ##Log socket opened, DONE fconfigure - token $token + } + + Log "Using $sock for $state(socketinfo) - token $token" \ + [expr {$state(-keepalive)?"keepalive":""}] + + # Code above has set state(sock) $sock + ConfigureNewSocket $token $sockOld $DoLater + ##Log OpenSocket success $sock - token $token + } result errdict]} { + ##Log OpenSocket failed $result - token $token + # There may be other requests in the socketPhQueue. + # Prepare socketPlayCmd so that Finish will replay them. + if { ($state(-keepalive)) && (!$state(reusing)) + && [info exists socketPhQueue($sockOld)] + && ($socketPhQueue($sockOld) ne {}) + } { + if {$socketMapping($state(socketinfo)) ne $sockOld} { + Log "WARNING: this code should not be reached.\ + {$socketMapping($state(socketinfo)) ne $sockOld}" + } + set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] + set socketPhQueue($sockOld) {} + } + if {[string range $result 0 20] eq {proxy connect failed:}} { + # - The HTTPS proxy did not create a socket. The pre-existing value + # (a "placeholder socket") is unchanged. + # - The proxy returned a valid HTTP response to the failed CONNECT + # request, and http::SecureProxyConnect copied this to $token, + # and also set ${token}(connection) set to "close". + # - Remove the error message $result so that Finish delivers this + # HTTP response to the caller. + set result {} + } + Finish $token $result + # Because socket creation failed, the placeholder "socket" must be + # "closed" and (if persistent) removed from the persistent sockets + # table. In the {proxy connect failed:} case Finish does this because + # the value of ${token}(connection) is "close". In the other cases here, + # it does so because $result is non-empty. + } + ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token + return +} + + +# ------------------------------------------------------------------------------ +# Proc ::http::ConfigureNewSocket +# ------------------------------------------------------------------------------ +# Command to initialise a newly-created socket. Called only from OpenSocket. +# +# This command is called by OpenSocket whenever a genuine socket (sockNew) has +# been opened for for use by HTTP. It does two things: +# (1) If $token uses a placeholder socket, this command replaces the placeholder +# socket with the real socket, not only in $token but in all other requests +# that use the same placeholder. +# (2) It calls ScheduleRequest to schedule each request that uses the socket. +# +# +# Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder). +# sockNew is ${token}(sock) +# sockOld sockNew CASES +# sock sock (if $reusing, and sockOld is sock) +# ph sock (if (not $reusing), and sockOld is ph) +# ph ph (if $reusing, and sockOld is ph) - not called in this case +# sock ph (cannot occur unless a bug) - not called in this case +# (if (not $reusing), and sockOld is sock) - illogical +# +# Arguments: +# token - connection token (name of an array) +# sockOld - handle or placeholder used for a socket before the call to +# OpenSocket +# DoLater - dictionary of boolean values listing unfinished tasks +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::ConfigureNewSocket {token sockOld DoLater} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set reusing $state(reusing) + set sock $state(sock) + set proxyUsed $state(proxyUsed) + ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed + + if {(!$reusing) && ($sock ne $sockOld)} { + # Replace the placeholder value sockOld with sock. + + if { [info exists socketMapping($state(socketinfo))] + && ($socketMapping($state(socketinfo)) eq $sockOld) + } { + set socketMapping($state(socketinfo)) $sock + set socketProxyId($state(socketinfo)) $proxyUsed + # tokens that use the placeholder $sockOld are updated below. + ##Log set socketMapping($state(socketinfo)) $sock + } + + # Now finish any tasks left over from PreparePersistentConnection on + # the connection. + # + # The "unset" traces are fired by init (clears entire arrays), and + # by http::Unset. + # Unset is called by CloseQueuedQueries and (possibly never) by geturl. + # + # CancelReadPipeline, CancelWritePipeline call http::Finish for each + # token. + # + # FIXME If Finish is placeholder-aware, these traces can be set earlier, + # in PreparePersistentConnection. + + if {[dict get $DoLater -traceread]} { + set varName ::http::socketRdState($state(socketinfo)) + trace add variable $varName unset ::http::CancelReadPipeline + } + if {[dict get $DoLater -tracewrite]} { + set varName ::http::socketWrState($state(socketinfo)) + trace add variable $varName unset ::http::CancelWritePipeline + } + } + + # Do this in all cases. + ScheduleRequest $token + + # Now look at all other tokens that use the placeholder $sockOld. + if { (!$reusing) + && ($sock ne $sockOld) + && [info exists socketPhQueue($sockOld)] + } { + ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld) + foreach tok $socketPhQueue($sockOld) { + # 1. Amend the token's (sock). + ##Log set ${tok}(sock) $sock + set ${tok}(sock) $sock + set ${tok}(proxyUsed) $proxyUsed + + # 2. Schedule the token's HTTP request. + # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. + set ${tok}(reusing) 1 + set ${tok}(alreadyQueued) 0 + ScheduleRequest $tok + } + set socketPhQueue($sockOld) {} + } + ##Log " ConfigureNewSocket" $token DONE + + return +} + + +# ------------------------------------------------------------------------------ +# The values of array variables socketMapping etc. +# ------------------------------------------------------------------------------ +# connId "$host:$port" +# socketMapping($connId) the handle or placeholder for the socket that is used +# for "-keepalive 1" requests to $connId. +# socketRdState($connId) the token that is currently reading from the socket. +# Other values: Rready (ready for next token to read). +# socketWrState($connId) the token that is currently writing to the socket. +# Other values: Wready (ready for next token to write), +# peNding (would be ready for next write, except that +# the integrity of a non-pipelined transaction requires +# waiting until the read(s) in progress are finished). +# socketRdQueue($connId) List of tokens that are queued for reading later. +# socketWrQueue($connId) List of tokens that are queued for writing later. +# socketPhQueue($sock) List of tokens that are queued to use a placeholder +# socket, when the real socket has not yet been created. +# socketClosing($connId) (boolean) true iff a server response header indicates +# that the server will close the connection at the end of +# the current response. +# socketPlayCmd($connId) The command to execute to replay pending and +# part-completed transactions if the socket closes early. +# socketCoEvent($connId) Identifier for the "after idle" event that will launch +# an OpenSocket coroutine to open or re-use a socket. +# socketProxyId($connId) The type of proxy that this socket uses: values are +# those of state(proxyUsed) i.e. none, HttpProxy, +# SecureProxy, and SecureProxyFailed. +# The value is not used for anything by http, its purpose +# is to set the value of state() for caller information. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Using socketWrState(*), socketWrQueue(*), socketRdState(*), socketRdQueue(*) +# ------------------------------------------------------------------------------ +# 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. +# ------------------------------------------------------------------------------ + + +# ------------------------------------------------------------------------------ +# Proc http::ScheduleRequest +# ------------------------------------------------------------------------------ +# Command to either begin the HTTP request, or add it to the appropriate queue. +# Called from two places in ConfigureNewSocket. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::ScheduleRequest {token} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + Log >L$tk ScheduleRequest + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + set Unfinished 0 + + set reusing $state(reusing) + set sockNew $state(sock) + + # The "if" tests below: must test against the current values of + # socketWrState, socketRdState, and so the tests must be done here, + # not earlier in PreparePersistentConnection. + + if {$state(alreadyQueued)} { + # The request has been appended to the queue of a persistent socket + # (that is scheduled to close and have its queue replayed). + # + # 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 new, init for pipelined, GRANT write access to $token in geturl + # DO NOT grant premature read access to the socket. + # set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } elseif {$reusing} { + # socketWrState is not used by this non-pipelined transaction. + # We cannot leave it as "Wready" because the next call to + # http::geturl with a pipelined transaction would conclude that the + # socket is available for writing. + #Log new, init for nonpipeline, GRANT r/w access to $token in geturl + set socketRdState($state(socketinfo)) $token + set socketWrState($state(socketinfo)) $token + } else { + } + + # Process the request now. + # - Command is not called unless $state(sock) is a real socket handle + # and not a placeholder. + # - All (!$reusing) cases come here. + # - Some $reusing cases come here too if the connection is + # marked as ready. Those $reusing cases are: + # $reusing && ($socketWrState($state(socketinfo)) eq "Wready") && + # EITHER !$pipeline && ($socketRdState($state(socketinfo)) eq "Rready") + # OR $pipeline + # + #Log ---- $state(socketinfo) << conn to $token for HTTP request (a) + ##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token + # Connect does its own fconfigure. + + lassign $state(connArgs) proto phost srvurl + + if {[catch { + fileevent $state(sock) writable \ + [list http::Connect $token $proto $phost $srvurl] + } res opts]} { + # The socket no longer exists. + ##Log bug -- socket gone -- $res -- $opts + } + + } + + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::SendHeader +# ------------------------------------------------------------------------------ +# Command to send a request header, and keep a copy in state(requestHeaders) +# for debugging purposes. +# +# Arguments: +# token - connection token (name of an array) +# key - header name +# value - header value +# +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::SendHeader {token key value} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + set sock $state(sock) + lappend state(requestHeaders) [string tolower $key] $value + puts $sock "$key: $value" + return +} + +# http::Connected -- +# +# Callback used when the connection to the HTTP server is actually +# established. +# +# Arguments: +# 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: +# None. + +proc http::Connected {token proto phost srvurl} { + variable http + variable urlTypes + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + 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)] + set isQuery [info exists state(-query)] + regexp {^(.+):([^:]+)$} $state(socketinfo) {} host port + + set lower [string tolower $proto] + set defport [lindex $urlTypes($lower) 0] + + # Send data in cr-lf format, but accept any line terminators. + # 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] \ + -buffersize $state(-blocksize) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + + # The following is disallowed in safe interpreters, but the socket is + # already in non-blocking mode in that case. + + catch {fconfigure $sock -blocking off} + set how GET + if {$isQuery} { + set state(querylength) [string length $state(-query)] + if {$state(querylength) > 0} { + set how POST + set contDone 0 + } else { + # There's no query data. + unset state(-query) + set isQuery 0 + } + } elseif {$state(-validate)} { + set how HEAD + } elseif {$isQueryChannel} { + set how POST + # The query channel must be blocking for the async Write to + # work properly. + fconfigure $state(-querychannel) -blocking 1 -translation binary + set contDone 0 + } + if {[info exists state(-method)] && ($state(-method) ne "")} { + set how $state(-method) + } + set accept_types_seen 0 + + Log ^B$tk begin sending request - token $token + + if {[catch { + if {[info exists state(bypass)]} { + set state(method) [lindex [split $state(bypass) { }] 0] + set state(requestHeaders) {} + set state(requestLine) $state(bypass) + } else { + set state(method) $how + set state(requestHeaders) {} + set state(requestLine) "$how $srvurl HTTP/$state(-protocol)" + } + puts $sock $state(requestLine) + set hostValue [GetFieldValue $state(-headers) Host] + if {$hostValue ne {}} { + # Allow Host spoofing. [Bug 928154] + regexp {^[^:]+} $hostValue state(host) + SendHeader $token Host $hostValue + } elseif {$port == $defport} { + # Don't add port in this case, to handle broken servers. [Bug + # #504508] + set state(host) $host + SendHeader $token Host $host + } else { + set state(host) $host + SendHeader $token Host "$host:$port" + } + SendHeader $token User-Agent $http(-useragent) + if {($state(-protocol) > 1.0) && $state(-keepalive)} { + # Send this header, because a 1.1 server is not compelled to treat + # this as the default. + set ConnVal keep-alive + } elseif {($state(-protocol) > 1.0)} { + # RFC2616 sec 8.1.2.1 + set ConnVal close + } else { + # ($state(-protocol) <= 1.0) + # RFC7230 A.1 + # Some server implementations of HTTP/1.0 have a faulty + # implementation of RFC 2068 Keep-Alive. + # Don't leave this to chance. + # For HTTP/1.0 we have already "set state(connection) close" + # and "state(-keepalive) 0". + set ConnVal close + } + # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by + # Pat Thoyts). + if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { + SendHeader $token Proxy-Authorization $http(-proxyauth) + } + # RFC7230 A.1 - "clients are encouraged not to send the + # Proxy-Connection header field in any requests" + set accept_encoding_seen 0 + set content_type_seen 0 + set connection_seen 0 + foreach {key value} $state(-headers) { + set value [string map [list \n "" \r ""] $value] + set key [string map {" " -} [string trim $key]] + if {[string equal -nocase $key "host"]} { + continue + } + if {[string equal -nocase $key "accept-encoding"]} { + set accept_encoding_seen 1 + } + if {[string equal -nocase $key "accept"]} { + set accept_types_seen 1 + } + if {[string equal -nocase $key "content-type"]} { + set content_type_seen 1 + } + if {[string equal -nocase $key "content-length"]} { + set contDone 1 + set state(querylength) $value + } + if { [string equal -nocase $key "connection"] + && [info exists state(bypass)] + } { + # Value supplied in -headers overrides $ConnVal. + set connection_seen 1 + } elseif {[string equal -nocase $key "connection"]} { + # Remove "close" or "keep-alive" and use our own value. + # In an upgrade request, the upgrade is not guaranteed. + # Value "close" or "keep-alive" tells the server what to do + # if it refuses the upgrade. We send a single "Connection" + # header because some websocket servers, e.g. civetweb, reject + # multiple headers. Bug [d01de3281f] of tcllib/websocket. + set connection_seen 1 + set listVal $state(connectionValues) + if {[set pos [lsearch $listVal close]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + if {[set pos [lsearch $listVal keep-alive]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + lappend listVal $ConnVal + set value [join $listVal {, }] + } + if {[string length $key]} { + SendHeader $token $key $value + } + } + # Allow overriding the Accept header on a per-connection basis. Useful + # for working with REST services. [Bug c11a51c482] + if {!$accept_types_seen} { + SendHeader $token Accept $state(accept-types) + } + if { (!$accept_encoding_seen) + && (![info exists state(-handler)]) + && $http(-zip) + } { + SendHeader $token Accept-Encoding gzip,deflate + } elseif {!$accept_encoding_seen} { + SendHeader $token Accept-Encoding identity + } else { + } + if {!$connection_seen} { + SendHeader $token Connection $ConnVal + } + if {$isQueryChannel && ($state(querylength) == 0)} { + # Try to determine size of data in channel. If we cannot seek, the + # surrounding catch will trap us + + set start [tell $state(-querychannel)] + seek $state(-querychannel) 0 end + set state(querylength) \ + [expr {[tell $state(-querychannel)] - $start}] + seek $state(-querychannel) $start + } + + # Note that we don't do Cookie2; that's much nastier and not normally + # observed in practice either. It also doesn't fix the multitude of + # bugs in the basic cookie spec. + if {$http(-cookiejar) ne ""} { + set cookies "" + set separator "" + foreach {key value} [{*}$http(-cookiejar) \ + getCookies $proto $host $state(path)] { + append cookies $separator $key = $value + set separator "; " + } + if {$cookies ne ""} { + SendHeader $token Cookie $cookies + } + } + + # Flush the request header and set up the fileevent that will either + # push the POST data or read the response. + # + # fileevent note: + # + # It is possible to have both the read and write fileevents active at + # this point. The only scenario it seems to affect is a server that + # closes the connection without reading the POST data. (e.g., early + # versions TclHttpd in various error cases). Depending on the + # platform, the client may or may not be able to get the response from + # the server because of the error it will get trying to write the post + # data. Having both fileevents active changes the timing and the + # behavior, but no two platforms (among Solaris, Linux, and NT) behave + # the same, and none behave all that well in any case. Servers should + # always read their POST data if they expect the client to read their + # response. + + if {$isQuery || $isQueryChannel} { + # POST method. + if {!$content_type_seen} { + SendHeader $token Content-Type $state(-type) + } + if {!$contDone} { + SendHeader $token 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] + # 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 + 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, 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)} { + # 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} + } + + # 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 ""} { + # https handshake errors come here, for + # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg {failed to use socket} + } + Finish $token $msg + } elseif {$state(status) ne "error"} { + Finish $token $err + } + } + 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 +} + +# http::DoneRequest -- +# +# 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 + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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" + # 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 + # value of socketRdState. + # In the nonpipeline case, connection for reading always occurs. + 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 ---- $state(socketinfo) >> conn to $token for HTTP response + lassign [fconfigure $sock -translation] trRead trWrite + fconfigure $sock -translation [list auto $trWrite] \ + -buffersize $state(-blocksize) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile tcl8 + } + Log ^D$tk begin receiving response - token $token + + coroutine ${token}--EventCoroutine http::Event $sock $token + if {[info exists state(-handler)] || [info exists state(-progress)]} { + fileevent $sock readable [list http::EventGateway $sock $token] + } else { + fileevent $sock readable ${token}--EventCoroutine + } + return +} + + +# http::EventGateway +# +# Bug [c2dc1da315]. +# - Recursive launch of the coroutine can occur if a -handler or -progress +# callback is used, and the callback command enters the event loop. +# - To prevent this, the fileevent "binding" is disabled while the +# coroutine is in flight. +# - If a recursive call occurs despite these precautions, it is not +# trapped and discarded here, because it is better to report it as a +# bug. +# - Although this solution is believed to be sufficiently general, it is +# used only if -handler or -progress is specified. In other cases, +# the coroutine is called directly. + +proc http::EventGateway {sock token} { + variable $token + upvar 0 $token state + fileevent $sock readable {} + catch {${token}--EventCoroutine} res opts + if {[info commands ${token}--EventCoroutine] ne {}} { + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::MakeTransformationChunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} + } + + # If there was an error, re-throw it. + return -options $opts $res +} + + +# 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 socketClosing + variable $token + upvar 0 $token state + set connId $state(socketinfo) + + 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") + + && [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}(connArgs)] + 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. + set conn [set ${token3}(connArgs)] + #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 + } + return +} + +# http::CancelReadPipeline +# +# Cancel pipelined responses on a closing "Keep-Alive" socket. +# +# - 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. +# +# 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 by CancelReadPipeline} + 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 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. +# - 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. +# +# 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 by CancelWritePipeline} + 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 {token doing} { + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + upvar 0 $token state + + Log running http::ReplayIfDead for $token $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 {$state(-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($state(socketinfo))] + && ($socketRdState($state(socketinfo)) ne "Rready") + } { + lappend InFlightR $socketRdState($state(socketinfo)) + } elseif {($doing eq "read")} { + lappend InFlightR $token + } + + if { [info exists socketWrState($state(socketinfo))] + && $socketWrState($state(socketinfo)) ni {Wready peNding} + } { + lappend InFlightW $socketWrState($state(socketinfo)) + } elseif {($doing eq "write")} { + lappend InFlightW $token + } + + # Report any inconsistency of $token with socket*state. + if { ($doing eq "read") + && [info exists socketRdState($state(socketinfo))] + && ($token ne $socketRdState($state(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined token $token $doing \ + ne socketRdState($state(socketinfo)) \ + $socketRdState($state(socketinfo)) + + } elseif { + ($doing eq "write") + && [info exists socketWrState($state(socketinfo))] + && ($token ne $socketWrState($state(socketinfo))) + } { + Log WARNING - ReplayIfDead pipelined token $token $doing \ + ne socketWrState($state(socketinfo)) \ + $socketWrState($state(socketinfo)) + } + } else { + # One transaction should be in flight. + # socketRdState, socketWrQueue are used. + # socketRdQueue should be empty. + + # Report any inconsistency of $token with socket*state. + if {$token ne $socketRdState($state(socketinfo))} { + Log WARNING - ReplayIfDead nonpipeline token $token $doing \ + ne socketRdState($state(socketinfo)) \ + $socketRdState($state(socketinfo)) + } + + # Report the inconsistency that socketRdQueue is non-empty. + if { [info exists socketRdQueue($state(socketinfo))] + && ($socketRdQueue($state(socketinfo)) ne {}) + } { + Log WARNING - ReplayIfDead nonpipeline token $token $doing \ + has read queue socketRdQueue($state(socketinfo)) \ + $socketRdQueue($state(socketinfo)) ne {} + } + + lappend InFlightW $socketRdState($state(socketinfo)) + set socketRdQueue($state(socketinfo)) {} + } + + set newQueue {} + lappend newQueue {*}$InFlightR + lappend newQueue {*}$socketRdQueue($state(socketinfo)) + lappend newQueue {*}$InFlightW + lappend newQueue {*}$socketWrQueue($state(socketinfo)) + + + # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket. + # Do not change state(status). + # No need to after cancel state(after) - either this is done in + # ReplayCore/ReInit, or Finish is called. + + catch {close $state(sock)} + Unset $state(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 +} + +# 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 + } + ##Log $Rqueue -- $InFlightW -- $Wqueue + set newQueue {} + lappend newQueue {*}$Rqueue + lappend newQueue {*}$InFlightW + lappend newQueue {*}$Wqueue + + # 2. Cleanup - none needed, done by the caller. + + ReplayCore $newQueue + 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) + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (ReInit) + after cancel $state(socketcoro) + unset state(socketcoro) + } + + # Don't alter state(status) - this would trigger http::wait if it is in use. + 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. +# +# 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 TmpSockCounter + + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 {![ReInit $token]} { + Log FAILED in http::ReplayCore - NO tmp vars + Log ReplayCore reject $token + Finish $token {cannot send this request again} + return + } + + set tmpState $state(tmpState) + set tmpOpenCmd $state(tmpOpenCmd) + set tmpConnArgs $state(tmpConnArgs) + unset state(tmpState) + unset state(tmpOpenCmd) + unset state(tmpConnArgs) + + set state(reusing) 0 + set state(ReusingPlaceholder) 0 + set state(alreadyQueued) 0 + Log ReplayCore replay $token + + # Give the socket a placeholder name before it is created. + set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] + set state(sock) $sock + + # Move the $newQueue into the placeholder socket's socketPhQueue. + set socketPhQueue($sock) {} + foreach tok $newQueue { + if {[ReInit $tok]} { + set ${tok}(reusing) 1 + set ${tok}(sock) $sock + lappend socketPhQueue($sock) $tok + Log ReplayCore replay $tok + } else { + Log ReplayCore reject $tok + set ${tok}(reusing) 1 + set ${tok}(sock) NONE + Finish $tok {cannot send this request again} + } + } + + AsyncTransaction $token + + return +} + +# Data access functions: +# Data - the URL data +# Status - the transaction status: ok, reset, eof, timeout, error +# Code - the HTTP transaction code, e.g., 200 +# Size - the size of the URL data + +proc http::responseBody {token} { + variable $token + upvar 0 $token state + return $state(body) +} +proc http::status {token} { + if {![info exists $token]} { + return "error" + } + variable $token + upvar 0 $token state + return $state(status) +} +proc http::responseLine {token} { + variable $token + upvar 0 $token state + return $state(http) +} +proc http::requestLine {token} { + variable $token + upvar 0 $token state + return $state(requestLine) +} +proc http::responseCode {token} { + variable $token + upvar 0 $token state + if {[regexp {[0-9]{3}} $state(http) numeric_code]} { + return $numeric_code + } else { + return $state(http) + } +} +proc http::size {token} { + variable $token + upvar 0 $token state + return $state(currentsize) +} +proc http::requestHeaders {token args} { + set lenny [llength $args] + if {$lenny > 1} { + return -code error {usage: ::http::requestHeaders token ?headerName?} + } else { + return [Meta $token request {*}$args] + } +} +proc http::responseHeaders {token args} { + set lenny [llength $args] + if {$lenny > 1} { + return -code error {usage: ::http::responseHeaders token ?headerName?} + } else { + return [Meta $token response {*}$args] + } +} +proc http::requestHeaderValue {token header} { + Meta $token request $header VALUE +} +proc http::responseHeaderValue {token header} { + Meta $token response $header VALUE +} +proc http::Meta {token who args} { + variable $token + upvar 0 $token state + + if {$who eq {request}} { + set whom requestHeaders + } elseif {$who eq {response}} { + set whom meta + } else { + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + } + + set header [string tolower [lindex $args 0]] + set how [string tolower [lindex $args 1]] + set lenny [llength $args] + if {$lenny == 0} { + return $state($whom) + } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} { + return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??} + } else { + set result {} + set combined {} + foreach {key value} $state($whom) { + if {$key eq $header} { + lappend result $key $value + append combined $value {, } + } + } + if {$lenny == 1} { + return $result + } else { + return [string range $combined 0 end-2] + } + } +} + + +# ------------------------------------------------------------------------------ +# Proc http::responseInfo +# ------------------------------------------------------------------------------ +# Command to return a dictionary of the most useful metadata of a HTTP +# response. +# +# Arguments: +# token - connection token (name of an array) +# +# Return Value: a dict. See man page http(n) for a description of each item. +# ------------------------------------------------------------------------------ + +proc http::responseInfo {token} { + variable $token + upvar 0 $token state + set result {} + foreach {key origin name} { + stage STATE state + status STATE status + responseCode STATE responseCode + reasonPhrase STATE reasonPhrase + contentType STATE type + binary STATE binary + redirection RESP location + upgrade STATE upgrade + error ERROR - + postError STATE posterror + method STATE method + charset STATE charset + compression STATE coding + httpRequest STATE -protocol + httpResponse STATE httpResponse + url STATE url + connectionRequest REQ connection + connectionResponse RESP connection + connectionActual STATE connection + transferEncoding STATE transfer + totalPost STATE querylength + currentPost STATE queryoffset + totalSize STATE totalsize + currentSize STATE currentsize + proxyUsed STATE proxyUsed + } { + if {$origin eq {STATE}} { + if {[info exists state($name)]} { + dict set result $key $state($name) + } else { + # Should never come here + dict set result $key {} + } + } elseif {$origin eq {REQ}} { + dict set result $key [requestHeaderValue $token $name] + } elseif {$origin eq {RESP}} { + dict set result $key [responseHeaderValue $token $name] + } elseif {$origin eq {ERROR}} { + # Don't flood the dict with data. The command ::http::error is + # available. + if {[info exists state(error)]} { + set msg [lindex $state(error) 0] + } else { + set msg {} + } + dict set result $key $msg + } else { + # Should never come here + dict set result $key {} + } + } + return $result +} +proc http::error {token} { + variable $token + upvar 0 $token state + if {[info exists state(error)]} { + return $state(error) + } + return +} +proc http::postError {token} { + variable $token + upvar 0 $token state + if {[info exists state(postErrorFull)]} { + return $state(postErrorFull) + } + return +} + +# http::cleanup +# +# Garbage collect the state associated with a transaction +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# Unsets the state array. + +proc http::cleanup {token} { + variable $token + upvar 0 $token state + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (cleanup) + after cancel $state(socketcoro) + unset state(socketcoro) + } + if {[info exists state]} { + unset state + } + return +} + +# http::Connect +# +# This callback is made when an asynchronous connection completes. +# +# Arguments +# token The token returned from http::geturl +# +# Side Effects +# Sets the status of the connection, which unblocks +# the waiting geturl call + +proc http::Connect {token proto phost srvurl} { + variable $token + upvar 0 $token state + set tk [namespace tail $token] + + if {[catch {eof $state(sock)} tmp] || $tmp} { + set err "due to unexpected EOF" + } elseif {[set err [fconfigure $state(sock) -error]] ne ""} { + # set err is done in test + } else { + # All OK + set state(state) connecting + fileevent $state(sock) writable {} + ::http::Connected $token $proto $phost $srvurl + return + } + + # Error cases. + 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. + 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" + return +} + +# http::Write +# +# Write POST query data to the socket +# +# Arguments +# token The token for the connection +# +# Side Effects +# Write the socket and handle callbacks. + +proc http::Write {token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + 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 + set done 0 + if {[catch { + # Catch I/O errors on dead sockets + + 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}]] + incr state(queryoffset) $state(-queryblocksize) + if {$state(queryoffset) >= $state(querylength)} { + set state(queryoffset) $state(querylength) + set done 1 + } + } else { + # 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)]} { + set done 1 + } + } + } err opts]} { + # Do not call Finish here, but instead let the read half of the socket + # process whatever server reply there is to get. + set state(posterror) $err + set info [dict get $opts -errorinfo] + set code [dict get $opts -code] + set state(postErrorFull) [list $err $info $code] + set done 1 + } + + if {$done} { + catch {flush $sock} + fileevent $sock writable {} + 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. + + if {[string length $state(-queryprogress)]} { + namespace eval :: $state(-queryprogress) \ + [list $token $state(querylength) $state(queryoffset)] + } + return +} + +# http::Event +# +# 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. +# token The token returned from http::geturl +# +# Side Effects +# Read the socket and handle callbacks. + +proc http::Event {sock token} { + variable http + variable socketMapping + variable socketRdState + variable socketWrState + variable socketRdQueue + variable socketWrQueue + variable socketPhQueue + variable socketClosing + variable socketPlayCmd + variable socketCoEvent + variable socketProxyId + + variable $token + upvar 0 $token state + set tk [namespace tail $token] + while 1 { + yield + ##Log Event call - token $token + + if {![info exists state]} { + Log "Event $sock with invalid token '$token' - remote close?" + if {!([catch {eof $sock} tmp] || $tmp)} { + if {[set d [read $sock]] ne ""} { + Log "WARNING: additional data left on closed socket\ + - token $token" + } else { + } + } else { + } + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + return + } else { + } + 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]] + } else { + } + + 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 + } else { + } + # 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 { + # https handshake errors come here, for + # Tcl 8.7 with http::SecureProxyConnect. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg $nsl + } + Log ^X$tk end of response (error) - token $token + Finish $token $msg + return + } + } elseif {$nsl >= 0} { + ##Log - connecting 1 - token $token + set state(state) "header" + } elseif { ([catch {eof $sock} tmp] || $tmp) + && [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 { + } + + # 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 { + } + } 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) == "") + || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100) + } { + set state(state) "connecting" + continue + # This was a "return" in the pre-coroutine code. + } else { + } + + # We have $state(http) so let's split it into its components. + if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \ + -> httpResponse responseCode reasonPhrase] + } { + set state(httpResponse) $httpResponse + set state(responseCode) $responseCode + set state(reasonPhrase) $reasonPhrase + } else { + set state(httpResponse) $state(http) + set state(responseCode) $state(http) + set state(reasonPhrase) $state(http) + } + + if { ([info exists state(connection)]) + && ([info exists socketMapping($state(socketinfo))]) + && ("keep-alive" in $state(connection)) + && ($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 + } else { + } + + # 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))]) + && ("close" in $state(connection)) + && ($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. + Log $token socket will close after this transaction + # 1. Cancel socket-assignment coro events that have not yet + # launched, and add the tokens to the write queue. + if {[info exists socketCoEvent($state(socketinfo))]} { + foreach {tok can} $socketCoEvent($state(socketinfo)) { + lappend socketWrQueue($state(socketinfo)) $tok + unset -nocomplain ${tok}(socketcoro) + after cancel $can + Log $tok Cancel socket after-idle event (Event) + Log Move $tok from socketCoEvent to socketWrQueue and cancel its after idle coro + } + set socketCoEvent($state(socketinfo)) {} + } else { + } + + 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))] + + # - 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 tokenVal $socketRdQueue($state(socketinfo)) { + if {[info exists ${tokenVal}(after)]} { + after cancel [set ${tokenVal}(after)] + unset ${tokenVal}(after) + } else { + } + # Tokens in the read queue have no (socketcoro) to + # cancel. + } + } else { + set socketPlayCmd($state(socketinfo)) \ + {ReplayIfClose Wready {} {}} + } + + # Do not allow further connections on this socket (but + # geturl can add new requests to the replay). + set socketClosing($state(socketinfo)) 1 + } else { + } + + set state(state) body + + # According to + # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Connection + # any comma-separated "Connection:" list implies keep-alive, but I + # don't see this in the RFC so we'll play safe and + # scan any list for "close". + # Done here to support combining duplicate header field's values. + if { [info exists state(connection)] + && ("close" ni $state(connection)) + && ("keep-alive" ni $state(connection)) + } { + lappend state(connection) "keep-alive" + } else { + } + + # 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 + } elseif { + ($state(method) eq {CONNECT}) + && [string is integer -strict $state(responseCode)] + && ($state(responseCode) >= 200) + && ($state(responseCode) < 300) + } { + # A successful CONNECT response has no body. + # (An unsuccessful CONNECT has headers and body.) + # The code below is abstracted from Eot/Finish, but + # keeps the socket open. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + set state(state) complete + set state(status) ok + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if { [info exists state(-command)] + && (![info exists state(done-command-cb)]) + } { + set state(done-command-cb) yes + if {[catch {namespace eval :: $state(-command) $token} err]} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + return + } else { + } + + # - 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 + # (totalsize == 0). + + if { (!( [info exists state(connection)] + && ("close" in $state(connection)) + ) + ) + && ($state(transfer) eq {}) + && ($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 + } else { + } + + # 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 + } else { + } + if {[info exists state(-channel)]} { + if {$state(binary) || [llength [ContentEncoding $token]]} { + fconfigure $state(-channel) -translation binary + } else { + } + if {![info exists state(-handler)]} { + # Initiate a sequence of background fcopies. + fileevent $sock readable {} + rename ${token}--EventCoroutine {} + CopyStart $sock $token + return + } else { + } + } else { + } + } elseif {$nhl > 0} { + # Process header lines. + ##Log header - token $token - $line + if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { + set key [string tolower $key] + switch -- $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 { + # RFC 7230 Section 6.1 states that a comma-separated + # list is an acceptable value. + if {![info exists state(connectionRespFlag)]} { + # This is the first "Connection" response header. + # Scrub the earlier value set by iniitialisation. + set state(connectionRespFlag) {} + set state(connection) {} + } + foreach el [SplitCommaSeparatedFieldValue $value] { + lappend state(connection) [string tolower $el] + } + } + upgrade { + set state(upgrade) [string trim $value] + } + set-cookie { + if {$http(-cookiejar) ne ""} { + ParseCookie $token [string trim $value] + } else { + } + } + } + lappend state(meta) $key [string trim $value] + } else { + } + } else { + } + } else { + # Now reading body + ##Log body - token $token + if {[catch { + if {[info exists state(-handler)]} { + set n [namespace 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 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. + set state(state) complete + } else { + } + 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 + } + } 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 + 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 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 + 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 chunk $n cumul $state(log_size) -\ + token $token + } else { + } + 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 + } else { + } + # 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, or eof. + ##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 + 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 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 + } else { + } + } + # 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 another $n currentsize $c totalsize $t -\ + token $token + } else { + } + # 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 + } else { + } + } else { + } + } err]} { + Log ^X$tk end of response (error ${err}) - token $token + Finish $token $err + return + } else { + if {[info exists state(-progress)]} { + namespace eval :: $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } else { + } + } + } + + # 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} { + # [eof sock] succeeded and the result was 1 + ##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 { + # open connection closed on a token that has been cleaned up. + Log ^X$tk end of response (token error) - token $token + CloseSocket $sock + } + } else { + # EITHER [eof sock] failed - presumed done by Eot + # OR [eof sock] succeeded and the result was 0 + } + } + 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 +# the data as binary. [Bug 838e99a76d] +# +# Arguments +# type The content-type of the data. +# +# Results: +# Boolean, true if we definitely should be binary. + +proc http::IsBinaryContentType {type} { + lassign [split [string tolower $type] "/;"] major minor + if {$major eq "text"} { + return false + } + # There's a bunch of XML-as-application-format things about. See RFC 3023 + # and so on. + if {$major eq "application"} { + set minor [string trimright $minor] + if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} { + return false + } + } + # Not just application/foobar+xml but also image/svg+xml, so let us not + # restrict things for now... + if {[string match "*+xml" $minor]} { + return false + } + return true +} + +proc http::ParseCookie {token value} { + variable http + variable CookieRE + variable $token + upvar 0 $token state + + if {![regexp $CookieRE $value -> cookiename cookieval opts]} { + # Bad cookie! No biscuit! + return + } + + # Convert the options into a list before feeding into the cookie store; + # ugly, but quite easy. + set realopts {hostonly 1 path / secure 0 httponly 0} + dict set realopts origin $state(host) + dict set realopts domain $state(host) + foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { + regexp {^(.*?)(?:=(.*))?$} $option -> optname optval + switch -exact -- [string tolower $optname] { + expires { + if {[catch { + #Sun, 06 Nov 1994 08:49:37 GMT + dict set realopts expires \ + [clock scan $optval -format "%a, %d %b %Y %T %Z"] + }] && [catch { + # Google does this one + #Mon, 01-Jan-1990 00:00:00 GMT + dict set realopts expires \ + [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] + }] && [catch { + # This is in the RFC, but it is also in the original + # Netscape cookie spec, now online at: + # + #Sunday, 06-Nov-94 08:49:37 GMT + dict set realopts expires \ + [clock scan $optval -format "%A, %d-%b-%y %T %Z"] + }]} {catch { + #Sun Nov 6 08:49:37 1994 + dict set realopts expires \ + [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] + }} + } + max-age { + # Normalize + if {[string is integer -strict $optval]} { + dict set realopts expires [expr {[clock seconds] + $optval}] + } + } + domain { + # From the domain-matches definition [RFC 2109, section 2]: + # Host A's name domain-matches host B's if [...] + # A is a FQDN string and has the form NB, where N is a + # non-empty name string, B has the form .B', and B' is a + # FQDN string. (So, x.y.com domain-matches .y.com but + # not y.com.) + if {$optval ne "" && ![string match *. $optval]} { + dict set realopts domain [string trimleft $optval "."] + dict set realopts hostonly [expr { + ! [string match .* $optval] + }] + } + } + path { + if {[string match /* $optval]} { + dict set realopts path $optval + } + } + secure - httponly { + dict set realopts [string tolower $optname] 1 + } + } + } + dict set realopts key $cookiename + dict set realopts value $cookieval + {*}$http(-cookiejar) storeCookie $realopts +} + +# http::GetTextLine -- +# +# Get one line with the stream in crlf mode. +# Used if Transfer-Encoding is chunked, to read the line that +# reports the size of the following chunk. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. +# +# Arguments +# sock The socket receiving input. +# +# Results: +# The line of text, without trailing newline + +proc http::GetTextLine {sock} { + set tr [fconfigure $sock -translation] + lassign $tr trRead trWrite + 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. +# Used when we expect to read a chunked-encoding +# chunk of known size. + +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 [expr {[catch {eof $sock} tmp] || $tmp}] + 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. +# Empty line is not distinguished from eof. The caller must +# be able to handle this. + +proc http::BlockingGets {sock} { + while 1 { + set count [gets $sock line] + set eof [expr {[catch {eof $sock} tmp] || $tmp}] + if {$count >= 0 || $eof} { + return $line + } else { + yield + } + } +} + +# http::CopyStart +# +# Error handling wrapper around fcopy +# +# Arguments +# sock The socket to copy from +# token The token returned from http::geturl +# +# Side Effects +# This closes the connection upon error + +proc http::CopyStart {sock token {initial 1}} { + upvar 0 $token state + if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # Use the standards-compliant choice. + set coding2 decompress + } else { + set coding2 $coding + } + lappend state(zlib) [zlib stream $coding2] + } + MakeTransformationChunked $sock [namespace code [list CopyChunk $token]] + } else { + if {$initial} { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # Use the standards-compliant choice. + set coding2 decompress + } else { + set coding2 $coding + } + zlib push $coding2 $sock + } + } + 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]} { + Finish $token $err + } + } + return +} + +proc http::CopyChunk {token chunk} { + upvar 0 $token state + if {[set count [string length $chunk]]} { + incr state(currentsize) $count + if {[info exists state(zlib)]} { + foreach stream $state(zlib) { + set chunk [$stream add $chunk] + } + } + puts -nonewline $state(-channel) $chunk + if {[info exists state(-progress)]} { + namespace eval :: [linsert $state(-progress) end \ + $token $state(totalsize) $state(currentsize)] + } + } else { + Log "CopyChunk Finish - token $token" + if {[info exists state(zlib)]} { + set excess "" + foreach stream $state(zlib) { + catch { + $stream put -finalize $excess + set excess "" + set overflood "" + while {[set overflood [$stream get]] ne ""} { append excess $overflood } + } + } + puts -nonewline $state(-channel) $excess + foreach stream $state(zlib) { $stream close } + unset state(zlib) + } + Eot $token ;# FIX ME: pipelining. + } + return +} + +# http::CopyDone +# +# fcopy completion callback +# +# Arguments +# token The token returned from http::geturl +# count The amount transferred +# +# Side Effects +# Invokes callbacks + +proc http::CopyDone {token count {error {}}} { + variable $token + upvar 0 $token state + set sock $state(sock) + incr state(currentsize) $count + if {[info exists state(-progress)]} { + namespace eval :: $state(-progress) \ + [list $token $state(totalsize) $state(currentsize)] + } + # At this point the token may have been reset. + if {[string length $error]} { + Finish $token $error + } elseif {[catch {eof $sock} iseof] || $iseof} { + Eot $token + } else { + CopyStart $sock $token 0 + } + return +} + +# 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. +# +# 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 (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 condition other than +# premature EOF. +# +# Side Effects +# Clean up the socket + +proc http::Eot {token {reason {}}} { + variable $token + upvar 0 $token state + 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 + } + + if {[string length $state(body)] > 0} { + if {[catch { + foreach coding [ContentEncoding $token] { + if {$coding eq {deflateX}} { + # First try the standards-compliant choice. + set coding2 decompress + if {[catch {zlib $coding2 $state(body)} result]} { + # If that fails, try the MS non-compliant choice. + set coding2 inflate + set state(body) [zlib $coding2 $state(body)] + } else { + # error {failed at standards-compliant deflate} + set state(body) $result + } + } else { + set state(body) [zlib $coding $state(body)] + } + } + } err]} { + Log "error doing decompression for token $token: $err" + Finish $token $err + return + } + + 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 + # encodings for. + + set enc [CharsetToEncoding $state(charset)] + if {$enc ne "binary"} { + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + } else { + set state(body) [encoding convertfrom $enc $state(body)] + } + } + + # Translate text line endings. + set state(body) [string map {\r\n \n \r \n} $state(body)] + } + if {[info exists state(-guesstype)] && $state(-guesstype)} { + GuessType $token + } + } + Finish $token $reason + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::GuessType +# ------------------------------------------------------------------------------ +# Command to attempt limited analysis of a resource with undetermined +# Content-Type, i.e. "application/octet-stream". This value can be set for two +# reasons: +# (a) by the server, in a Content-Type header +# (b) by http::geturl, as the default value if the server does not supply a +# Content-Type header. +# +# This command converts a resource if: +# (1) it has type application/octet-stream +# (2) it begins with an XML declaration "?" +# (3) one tag is named "encoding" and has a recognised value; or no "encoding" +# tag exists (defaulting to utf-8) +# +# RFC 9110 Sec. 8.3 states: +# "If a Content-Type header field is not present, the recipient MAY either +# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1) +# or examine the data to determine its type." +# +# The RFC goes on to describe the pitfalls of "MIME sniffing", including +# possible security risks. +# +# Arguments: +# token - connection token +# +# Return Value: (boolean) true iff a change has been made +# ------------------------------------------------------------------------------ + +proc http::GuessType {token} { + variable $token + upvar 0 $token state + + if {$state(type) ne {application/octet-stream}} { + return 0 + } + + set body $state(body) + # e.g. { ...} + + if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} { + return 0 + } + # e.g. {} + + set contents [regsub -- {[[:space:]]+} $match { }] + set contents [string range [string tolower $contents] 6 end-2] + # e.g. {version="1.0" encoding="utf-8"} + # without excess whitespace or upper-case letters + + if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} { + return 0 + } + # The application/xml default encoding: + set res utf-8 + + set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents] + foreach tag $tagList { + regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value + if {$name eq {encoding}} { + set res $value + } + } + set enc [CharsetToEncoding $res] + if {$enc eq "binary"} { + return 0 + } + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + } else { + set state(body) [encoding convertfrom $enc $state(body)] + } + set state(body) [string map {\r\n \n \r \n} $state(body)] + set state(type) application/xml + set state(binary) 0 + set state(charset) $res + return 1 +} + + +# http::wait -- +# +# See documentation for details. +# +# Arguments: +# token Connection token. +# +# Results: +# The status after the wait. + +proc http::wait {token} { + variable $token + upvar 0 $token state + + if {![info exists state(status)] || $state(status) eq ""} { + # We must wait on the original variable name, not the upvar alias + vwait ${token}(status) + } + + return [status $token] +} + +# http::formatQuery -- +# +# See documentation for details. Call http::formatQuery with an even +# number of arguments, where the first is a name, the second is a value, +# the third is another name, and so on. +# +# Arguments: +# args A list of name-value pairs. +# +# Results: +# 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 { + append result $sep [quoteString $i] + if {$sep eq "="} { + set sep & + } else { + set sep = + } + } + return $result +} + +# http::quoteString -- +# +# Do x-www-urlencoded character mapping +# +# Arguments: +# string The string the needs to be encoded +# +# Results: +# The encoded string + +proc http::quoteString {string} { + variable http + variable formMap + + # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use + # a pre-computed map and [string map] to do the conversion (much faster + # than [regsub]/[subst]). [Bug 1020491] + + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set string [encoding convertto -profile tcl8 $http(-urlencoding) $string] + } else { + set string [encoding convertto $http(-urlencoding) $string] + } + return [string map $formMap $string] +} + +# http::ProxyRequired -- +# Default proxy filter. +# +# Arguments: +# host The destination host +# +# Results: +# The current proxy settings + +proc http::ProxyRequired {host} { + variable http + if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { + return + } + if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { + set port 8080 + } else { + set port $http(-proxyport) + } + + # Simple test (cf. autoproxy) for hosts that must be accessed directly, + # not through the proxy server. + foreach domain $http(-proxynot) { + if {[string match -nocase $domain $host]} { + return {} + } + } + return [list $http(-proxyhost) $port] +} + +# http::CharsetToEncoding -- +# +# Tries to map a given IANA charset to a tcl encoding. If no encoding +# can be found, returns binary. +# + +proc http::CharsetToEncoding {charset} { + variable encodings + + set charset [string tolower $charset] + if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { + set encoding "iso8859-$num" + } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { + set encoding "iso2022-$ext" + } elseif {[regexp {shift[-_]?jis} $charset]} { + set encoding "shiftjis" + } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { + set encoding "cp$num" + } elseif {$charset eq "us-ascii"} { + set encoding "ascii" + } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { + switch -- $num { + 5 {set encoding "iso8859-9"} + 1 - 2 - 3 { + set encoding "iso8859-$num" + } + default { + set encoding "binary" + } + } + } else { + # other charset, like euc-xx, utf-8,... may directly map to encoding + set encoding $charset + } + set idx [lsearch -exact $encodings $encoding] + if {$idx >= 0} { + return $encoding + } else { + return "binary" + } +} + + +# ------------------------------------------------------------------------------ +# Proc http::ContentEncoding +# ------------------------------------------------------------------------------ +# Return the list of content-encoding transformations we need to do in order. +# + # -------------------------------------------------------------------------- + # Options for Accept-Encoding, Content-Encoding: the switch command + # -------------------------------------------------------------------------- + # The symbol deflateX allows http to attempt both versions of "deflate", + # unless there is a -channel - for a -channel, only "decompress" is tried. + # Alternative/extra lines for switch: + # The standards-compliant version of "deflate" can be chosen with: + # deflate { lappend r decompress } + # The Microsoft non-compliant version of "deflate" can be chosen with: + # deflate { lappend r inflate } + # The previously used implementation of "compress", which appears to be + # incorrect and is rarely used by web servers, can be chosen with: + # compress - x-compress { lappend r decompress } + # -------------------------------------------------------------------------- +# +# Arguments: +# token - Connection token. +# +# Return Value: list +# ------------------------------------------------------------------------------ + +proc http::ContentEncoding {token} { + upvar 0 $token state + set r {} + if {[info exists state(coding)]} { + foreach coding [split $state(coding) ,] { + switch -exact -- $coding { + deflate { lappend r deflateX } + gzip - x-gzip { lappend r gunzip } + identity {} + br { + return -code error\ + "content-encoding \"br\" not implemented" + } + default { + Log "unknown content-encoding \"$coding\" ignored" + } + } + } + } + return $r +} + +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 + } + } +} + +# http::SplitCommaSeparatedFieldValue -- +# Return the individual values of a comma-separated field value. +# +# Arguments: +# fieldValue Comma-separated header field value. +# +# Results: +# List of values. +proc http::SplitCommaSeparatedFieldValue {fieldValue} { + set r {} + foreach el [split $fieldValue ,] { + lappend r [string trim $el] + } + return $r +} + + +# http::GetFieldValue -- +# Return the value of a header field. +# +# Arguments: +# headers Headers key-value list +# fieldName Name of header field whose value to return. +# +# Results: +# The value of the fieldName header field +# +# Field names are matched case-insensitively (RFC 7230 Section 3.2). +# +# If the field is present multiple times, it is assumed that the field is +# defined as a comma-separated list and the values are combined (by separating +# them with commas, see RFC 7230 Section 3.2.2) and returned at once. +proc http::GetFieldValue {headers fieldName} { + set r {} + foreach {field value} $headers { + if {[string equal -nocase $fieldName $field]} { + if {$r eq {}} { + set r $value + } else { + append r ", $value" + } + } + } + return $r +} + +proc http::MakeTransformationChunked {chan command} { + coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command + chan event $chan readable [namespace current]::dechunk$chan + return +} + +interp alias {} http::data {} http::responseBody +interp alias {} http::code {} http::responseLine +interp alias {} http::mapReply {} http::quoteString +interp alias {} http::meta {} http::responseHeaders +interp alias {} http::metaValue {} http::responseHeaderValue +interp alias {} http::ncode {} http::responseCode + + +# ------------------------------------------------------------------------------ +# Proc http::socketForTls +# ------------------------------------------------------------------------------ +# Command to use in place of ::socket as the value of ::tls::socketCmd. +# This command does the same as http::socket, and also handles https connections +# through a proxy server. +# +# Notes. +# - The proxy server works differently for https and http. This implementation +# is for https. The proxy for http is implemented in http::CreateToken (in +# code that was previously part of http::geturl). +# - This code implicitly uses the tls options set for https in a call to +# http::register, and does not need to call commands tls::*. This simple +# implementation is possible because tls uses a callback to ::socket that can +# be redirected by changing the value of ::tls::socketCmd. +# +# Arguments: +# args - as for ::socket +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ + +proc http::socketForTls {args} { + variable http + set host [lindex $args end-1] + set port [lindex $args end] + if { ($http(-proxyfilter) ne {}) + && (![catch {$http(-proxyfilter) $host} proxy]) + } { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } else { + set phost {} + set pport {} + } + if {$phost eq ""} { + set sock [::http::socket {*}$args] + } else { + set sock [::http::SecureProxyConnect {*}$args $phost $pport] + } + return $sock +} + + +# ------------------------------------------------------------------------------ +# Proc http::SecureProxyConnect +# ------------------------------------------------------------------------------ +# Command to open a socket through a proxy server to a remote server for use by +# tls. The caller must perform the tls handshake. +# +# Notes +# - Based on patch supplied by Melissa Chawla in ticket 1173760, and +# Proxy-Authorization header cf. autoproxy by Pat Thoyts. +# - Rewritten as a call to http::geturl, because response headers and body are +# needed if the CONNECT request fails. CONNECT is implemented for this case +# only, by state(bypass). +# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT. +# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014), +# RFC 9112 (June 2022). +# +# Arguments: +# args - as for ::socket, ending in host, port; with proxy host, proxy +# port appended. +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ + +proc http::SecureProxyConnect {args} { + variable http + variable ConnectVar + variable ConnectCounter + variable failedProxyValues + set varName ::http::ConnectVar([incr ConnectCounter]) + + # Extract (non-proxy) target from args. + set host [lindex $args end-3] + set port [lindex $args end-2] + set args [lreplace $args end-3 end-2] + + # Proxy server URL for connection. + # This determines where the socket is opened. + set phost [lindex $args end-1] + set pport [lindex $args end] + if {[string first : $phost] != -1} { + # IPv6 address, wrap it in [] so we can append :pport + set phost "\[${phost}\]" + } + set url http://${phost}:${pport} + # Elements of args other than host and port are not used when + # AsyncTransaction opens a socket. Those elements are -async and the + # -type $tokenName for the https transaction. Option -async is used by + # AsyncTransaction anyway, and -type $tokenName should not be propagated: + # the proxy request adds its own -type value. + + set targ [lsearch -exact $args -type] + if {$targ != -1} { + # Record in the token that this is a proxy call. + set token [lindex $args $targ+1] + upvar 0 ${token} state + set tim $state(-timeout) + set state(proxyUsed) SecureProxyFailed + # This value is overwritten with "SecureProxy" below if the CONNECT is + # successful. If it is unsuccessful, the socket will be closed + # below, and so in this unsuccessful case there are no other transactions + # whose (proxyUsed) must be updated. + } else { + set tim 0 + } + if {$tim == 0} { + # Do not use infinite timeout for the proxy. + set tim 30000 + } + + # Prepare and send a CONNECT request to the proxy, using + # code similar to http::geturl. + set requestHeaders [list Host $host] + lappend requestHeaders Connection keep-alive + if {$http(-proxyauth) != {}} { + lappend requestHeaders Proxy-Authorization $http(-proxyauth) + } + + set token2 [CreateToken $url -keepalive 0 -timeout $tim \ + -headers $requestHeaders -command [list http::AllDone $varName]] + variable $token2 + upvar 0 $token2 state2 + + # Kludges: + # Setting this variable overrides the HTTP request line and also allows + # -headers to override the Connection: header set by -keepalive. + # The arguments "-keepalive 0" ensure that when Finish is called for an + # unsuccessful request, the socket is always closed. + set state2(bypass) "CONNECT $host:$port HTTP/1.1" + + AsyncTransaction $token2 + + if {[info coroutine] ne {}} { + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName + } else { + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName + } + unset $varName + + if { ($state2(state) ne "complete") + || ($state2(status) ne "ok") + || (![string is integer -strict $state2(responseCode)]) + } { + set msg {the HTTP request to the proxy server did not return a valid\ + and complete response} + if {[info exists state2(error)]} { + append msg ": " [lindex $state2(error) 0] + } + cleanup $token2 + return -code error $msg + } + + set code $state2(responseCode) + + if {($code >= 200) && ($code < 300)} { + # All OK. The caller in package tls will now call "tls::import $sock". + # The cleanup command does not close $sock. + # Other tidying was done in http::Event. + + # If this is a persistent socket, any other transactions that are + # already marked to use the socket will have their (proxyUsed) updated + # when http::OpenSocket calls http::ConfigureNewSocket. + set state(proxyUsed) SecureProxy + set sock $state2(sock) + cleanup $token2 + return $sock + } + + if {$targ != -1} { + # Non-OK HTTP status code; token is known because option -type + # (cf. targ) was passed through tcltls, and so the useful + # parts of the proxy's response can be copied to state(*). + # Do not copy state2(sock). + # Return the proxy response to the caller of geturl. + foreach name $failedProxyValues { + if {[info exists state2($name)]} { + set state($name) $state2($name) + } + } + set state(connection) close + set msg "proxy connect failed: $code" + # - This error message will be detected by http::OpenSocket and will + # cause it to present the proxy's HTTP response as that of the + # original $token transaction, identified only by state(proxyUsed) + # as the response of the proxy. + # - The cases where this would mislead the caller of http::geturl are + # given a different value of msg (below) so that http::OpenSocket will + # treat them as errors, but will preserve the $token array for + # inspection by the caller. + # - Status code 305 (Proxy Required) was deprecated for security reasons + # in RFC 2616 (June 1999) and in any case should never be served by a + # proxy. + # - Other 3xx responses from the proxy are inappropriate, and should not + # occur. + # - A 401 response from the proxy is inappropriate, and should not + # occur. It would be confusing if returned to the caller. + + if {($code >= 300) && ($code < 400)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate $code redirect" + set loc [responseHeaderValue $token2 location] + if {$loc ne {}} { + append msg "to " $loc + } + } elseif {($code == 401)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate 401 request for target-host credentials" + } else { + } + } else { + set msg "connection to proxy failed with status code $code" + } + + # - ${token2}(sock) has already been closed because -keepalive 0. + # - Error return does not pass the socket ID to the + # $token transaction, which retains its socket placeholder. + cleanup $token2 + return -code error $msg +} + +proc http::AllDone {varName args} { + set $varName done + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::socket +# ------------------------------------------------------------------------------ +# This command is a drop-in replacement for ::socket. +# Arguments and return value as for ::socket. +# +# Notes. +# - http::socket is specified in place of ::socket by the definition of urlTypes +# in the namespace header of this file (http.tcl). +# - The command makes a simple call to ::socket unless the user has called +# http::config to change the value of -threadlevel from the default value 0. +# - For -threadlevel 1 or 2, if the Thread package is available, the command +# waits in the event loop while the socket is opened in another thread. This +# is a workaround for bug [824251] - it prevents http::geturl from blocking +# the event loop if the DNS lookup or server connection is slow. +# - FIXME Use a thread pool if connections are very frequent. +# - FIXME The peer thread can transfer the socket only to the main interpreter +# in the present thread. Therefore this code works only if this script runs +# in the main interpreter. In a child interpreter, the parent must alias a +# command to ::http::socket in the child, run http::socket in the parent, +# and then transfer the socket to the child. +# - The http::socket command is simple, and can easily be replaced with an +# alternative command that uses a different technique to open a socket while +# entering the event loop. +# - Unexpected behaviour by thread::send -async (Thread 2.8.6). +# An error in thread::send -async causes return of just the error message +# (not the expected 3 elements), and raises a bgerror in the main thread. +# Hence wrap the command with catch as a precaution. +# ------------------------------------------------------------------------------ + +proc http::socket {args} { + variable ThreadVar + variable ThreadCounter + variable http + + LoadThreadIfNeeded + + set targ [lsearch -exact $args -type] + if {$targ != -1} { + set token [lindex $args $targ+1] + set args [lreplace $args $targ $targ+1] + upvar 0 $token state + } + + if {!$http(usingThread)} { + # Use plain "::socket". This is the default. + return [eval ::socket $args] + } + + set defcmd ::socket + set sockargs $args + set script " + set code \[catch { + [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]] + [list ::SockInThread [thread::id] $defcmd $sockargs] + } result opts\] + list \$code \$opts \$result + " + + set state(tid) [thread::create] + set varName ::http::ThreadVar([incr ThreadCounter]) + thread::send -async $state(tid) $script $varName + Log >T Thread Start Wait $args -- coro [info coroutine] $varName + if {[info coroutine] ne {}} { + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName + } else { + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName + } + Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName] + thread::release $state(tid) + set state(tid) {} + set result [set $varName] + unset $varName + if {(![string is list $result]) || ([llength $result] != 3)} { + return -code error "result from peer thread is not a list of\ + length 3: it is \n$result" + } + lassign $result threadCode threadDict threadResult + if {($threadCode != 0)} { + # This is an error in thread::send. Return the lot. + return -options $threadDict -code error $threadResult + } + + # Now the results of the catch in the peer thread. + lassign $threadResult catchCode errdict sock + + if {($catchCode == 0) && ($sock ni [chan names])} { + return -code error {Transfer of socket from peer thread failed.\ + Check that this script is not running in a child interpreter.} + } + return -options $errdict -code $catchCode $sock +} + +# The commands below are dependencies of http::socket and +# http::SecureProxyConnect and are not used elsewhere. + +# ------------------------------------------------------------------------------ +# Proc http::LoadThreadIfNeeded +# ------------------------------------------------------------------------------ +# Command to load the Thread package if it is needed. If it is needed and not +# loadable, the outcome depends on $http(-threadlevel): +# value 0 => Thread package not required, no problem +# value 1 => operate as if -threadlevel 0 +# value 2 => error return +# +# Arguments: none +# Return Value: none +# ------------------------------------------------------------------------------ + +proc http::LoadThreadIfNeeded {} { + variable http + if {$http(usingThread) || ($http(-threadlevel) == 0)} { + return + } + if {[catch {package require Thread}]} { + if {$http(-threadlevel) == 2} { + set msg {[http::config -threadlevel] has value 2,\ + but the Thread package is not available} + return -code error $msg + } + return + } + set http(usingThread) 1 + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::SockInThread +# ------------------------------------------------------------------------------ +# Command http::socket is a ::socket replacement. It defines and runs this +# command, http::SockInThread, in a peer thread. +# +# Arguments: +# caller +# defcmd +# sockargs +# +# Return value: list of values that describe the outcome. The return is +# intended to be a normal (non-error) return in all cases. +# ------------------------------------------------------------------------------ + +proc http::SockInThread {caller defcmd sockargs} { + package require Thread + + set catchCode [catch {eval $defcmd $sockargs} sock errdict] + if {$catchCode == 0} { + set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict] + } + return [list $catchCode $errdict $sock] +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::cwait +# ------------------------------------------------------------------------------ +# Command to substitute for vwait, without the ordering issues. +# A command that uses cwait must be a coroutine that is launched by an event, +# e.g. fileevent or after idle, and has no calling code to be resumed upon +# "yield". It cannot return a value. +# +# Arguments: +# varName - fully-qualified name of the variable that the calling script +# will write to resume the coroutine. Any scalar variable or +# array element is permitted. +# coroName - (optional) name of the coroutine to be called when varName is +# written - defaults to this coroutine +# timeout - (optional) timeout value in ms +# timeoutValue - (optional) value to assign to varName if there is a timeout +# +# Return Value: none +# ------------------------------------------------------------------------------ + +namespace eval http::cwaiter { + namespace export cwait + variable log {} + variable logOn 0 +} + +proc http::cwaiter::cwait { + varName {coroName {}} {timeout {}} {timeoutValue {}} +} { + set thisCoro [info coroutine] + if {$thisCoro eq {}} { + return -code error {cwait cannot be called outside a coroutine} + } + if {$coroName eq {}} { + set coroName $thisCoro + } + if {[string range $varName 0 1] ne {::}} { + return -code error {argument varName must be fully qualified} + } + if {$timeout eq {}} { + set toe {} + } elseif {[string is integer -strict $timeout] && ($timeout > 0)} { + set toe [after $timeout [list set $varName $timeoutValue]] + } else { + return -code error {if timeout is supplied it must be a positive integer} + } + + set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] + trace add variable $varName write $cmd + CoLog "Yield $varName $coroName" + yield + CoLog "Resume $varName $coroName" + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::CwaitHelper +# ------------------------------------------------------------------------------ +# Helper command called by the trace set by cwait. +# - Ignores the arguments added by trace. +# - A simple call to $coroName works, and in error cases gives a suitable stack +# trace, but because it is inside a trace the headline error message is +# something like {can't set "::Result(6)": error}, not the actual +# error. So let the trace command return. +# - Remove the trace immediately. We don't want multiple calls. +# ------------------------------------------------------------------------------ + +proc http::cwaiter::CwaitHelper {varName coroName toe args} { + CoLog "got $varName for $coroName" + set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe] + trace remove variable $varName write $cmd + after cancel $toe + + after 0 $coroName + return +} + + +# ------------------------------------------------------------------------------ +# Proc http::cwaiter::LogInit +# ------------------------------------------------------------------------------ +# Call this command to initiate debug logging and clear the log. +# ------------------------------------------------------------------------------ + +proc http::cwaiter::LogInit {} { + variable log + variable logOn + set log {} + set logOn 1 + return +} + +proc http::cwaiter::LogRead {} { + variable log + return $log +} + +proc http::cwaiter::CoLog {msg} { + variable log + variable logOn + if {$logOn} { + append log $msg \n + } + return +} + +namespace eval http { + namespace import ::http::cwaiter::* +} + +# Local variables: +# indent-tabs-mode: t +# End: diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm new file mode 100644 index 00000000..a65e1f7a --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -0,0 +1,1887 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punkcheck 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + +package require punk::tdl +package require punk::repo +package require punk::mix::util + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Punkcheck uses the TDL format which is a list of lists in Tcl format +# It is intended primarily for source build/distribution tracking within a punk project or single filesystem - with relative paths. +# +#see following article regarding the many problems with using mtime for build-decisions: https://apenwarr.ca/log/20181113 +# +namespace eval punkcheck { + namespace export\ + uuid\ + start_installer_event installfile_* + + variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + variable default_antiglob_file_core "" + proc uuid {} { + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + if {![catch {package require twapi}]} { + set has_twapi 1 + } + } + if {!$has_twapi} { + if {[catch {package require uuid} errM]} { + error "Unable to load a package for uuid on this platform. Try tcllib's uuid (any platform) - twapi for windows" + } + return [uuid::uuid generate] + } else { + return [twapi::new_uuid] + } + } + + proc default_antiglob_dir_core {} { + variable default_antiglob_dir_core + return $default_antiglob_dir_core + } + proc default_antiglob_file_core {} { + variable default_antiglob_file_core + if {$default_antiglob_file_core eq ""} { + set default_antiglob_file_core [list "*.swp" "*[punk::mix::util::magic_tm_version]*" "*-buildversion.txt" ".punkcheck"] + } + return $default_antiglob_file_core + } + + + proc load_records_from_file {punkcheck_file} { + set record_list [list] + if {[file exists $punkcheck_file]} { + set tdlscript [punk::mix::util::fcat $punkcheck_file] + set record_list [punk::tdl::prettyparse $tdlscript] + } + return $record_list + } + proc save_records_to_file {recordlist punkcheck_file} { + set newtdl [punk::tdl::prettyprint $recordlist] + set linecount [llength [split $newtdl \n]] + #puts stdout $newtdl + set fd [open $punkcheck_file w] + fconfigure $fd -translation binary + puts -nonewline $fd $newtdl + close $fd + return [list recordcount [llength $recordlist] linecount $linecount] + } + + + #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? + #an installtrack objects represents an installation path from sourceroot to targetroot + #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. + # + set objname [namespace current]::installtrack + if {$objname ni [info commands $objname]} { + package require oolib + + #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD + #each FILEINFO body being a list of SOURCE records + oo::class create targetset { + variable o_targets + variable o_keep_installrecords + variable o_keep_skipped + variable o_keep_inprogress + variable o_records + constructor {args} { + #set o_records [oolib::collection create [namespace current]::recordcollection] + set o_records [list] + + } + + method as_record {} { + + set fields [list\ + -targets $o_targets\ + -keep_installrecords $o_keep_installrecords\ + -keep_skipped $o_keep_skipped\ + -keep_inprogress $o_keep_inprogress\ + body $o_records\ + ] + + set record [dict create tag FILEINFO {*}$fields] + } + + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS + method get_last_record {fileset_record} { + set body [dict_getwithdefault $fileset_record body [list]] + set previous_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,DELETE-RECORD + set revlist [lreverse $previous_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "DELETE-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + } + + oo::class create installevent { + variable o_id + variable o_rel_sourceroot + variable o_rel_targetroot + variable o_ts_begin + variable o_ts_end + variable o_types + variable o_configdict + variable o_targets + variable o_operation + variable o_operation_start_ts + variable o_fileset_record + variable o_installer ;#parent object + constructor {installer rel_sourceroot rel_targetroot args} { + set o_installer $installer + set o_operation_start_ts "" + set o_operation "" + set defaults [dict create\ + -id ""\ + -tsbegin ""\ + -config [list]\ + -tsend ""\ + -types [list]\ + ] + set opts [dict merge $defaults $args] + if {[dict get $opts -id] eq ""} { + set o_id [punkcheck::uuid] + } else { + set o_id [dict get $opts -id] + } + if {[dict get $opts -tsbegin] eq ""} { + set o_ts_begin [clock microseconds] + } else { + set o_ts_begin [dict get $opts -tsbegin] + } + set o_ts_end [dict get $opts -tsend] + set o_types [dict get $opts -types] + set o_configdict [dict get $opts -config] + + set o_rel_sourceroot $rel_sourceroot + set o_rel_targetroot $rel_targetroot + } + destructor { + #puts "[self] destructor called" + } + method as_record {} { + set begin_seconds [expr {$o_ts_begin / 1000000}] + set tsiso_begin [clock format $begin_seconds -format "%Y-%m-%dT%H:%M:%S"] + if {$o_ts_end ne ""} { + set end_seconds [expr {$o_ts_end / 1000000}] + set tsiso_end [clock format $end_seconds -format "%Y-%m-%dT%H:%M:%S"] + } else { + set tsiso_end "" + } + set fields [list\ + -tsiso_begin $tsiso_begin\ + -ts_begin $o_ts_begin\ + -tsiso_end $tsiso_end\ + -ts_end $o_ts_end\ + -id $o_id\ + -source $o_rel_sourceroot\ + -targets $o_rel_targetroot\ + -types $o_types\ + -config $o_configdict\ + ] + + set record [dict create tag EVENT {*}$fields] + } + method get_id {} { + return $o_id + } + method get_operation {} { + return $o_operation + } + method get_targets {} { + return $o_targets + } + method get_targets_exist {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + set existing [list] + foreach t $o_targets { + if {[file exists [file join $punkcheck_folder $t]]} { + lappend existing $t + } + } + return $existing + } + method end {} { + set o_ts_end [clock microseconds] + } + method targetset_dict {} { + punk::records_as_target_dict [$o_installer get_recordlist] + } + + #related - installfile_begin + #call init before we know if we are going to run the operation vs skip + method targetset_init {operation targetset} { + set known_ops [list INSTALL MODIFY DELETE VIRTUAL] + if {[string toupper $operation] ni $known_ops} { + error "[self] add_target unknown operation '$operation'. Known operations $known_ops" + } + if {$o_operation_start_ts ne ""} { + error "[self] targetset_tart $o_operation operation already in progress. Use targetset_finished or targetset_complete to finish." + } + set o_operation_start_ts [clock microseconds] + set seconds [expr {$o_operation_start_ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set punkcheck_file [$o_installer get_checkfile] + + set relativepath_targetset [list] + foreach p $targetset { + if {[file pathtype $p] eq "absolute"} { + lappend relativepath_targetset [punkcheck::lib::path_relative [file dirname $punkcheck_file] $p] + } else { + lappend relativepath_targetset $p + } + } + + + set o_operation $operation + set fields [list\ + -tsiso $tsiso\ + -ts $o_operation_start_ts\ + -installer [$o_installer get_name]\ + -eventid $o_id\ + ] + + set o_targets [lsort -dictionary -increasing $relativepath_targetset] ;#exact sort order not critical - but must be consistent + + #set targetdict [my targetset_dict] + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $o_targets $record_list] + set o_fileset_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_inprogress_record [dict create tag [string toupper $operation]-INPROGRESS {*}$fields -tempcontext [my as_record] body {}] + #set existing_body [dict_getwithdefault $o_fileset_record body [list]] + #todo - look for existing "-INPROGRESS" records - mark as failed? + dict lappend o_fileset_record body $new_inprogress_record + + if {$isnew} { + lappend record_list $o_fileset_record + } else { + set record_list [linsert $record_list[unset record_list] $oldposition $o_fileset_record] + } + + punkcheck::save_records_to_file $record_list $punkcheck_file + return $o_fileset_record + + } + #operation has been started + method targetset_started {} { + set punkcheck_folder [file dirname [$o_installer get_checkfile]] + set o_fileset_record [punkcheck::installfile_started_install $punkcheck_folder $o_fileset_record] + } + method targetset_end {status args} { + set defaults [dict create\ + -note \uFFFF\ + ] + set known_opts [dict keys $defaults] + if {[llength $args] % 2 != 0} { + error "targetset_end arguments after status must be in the form of -flag value pairs. known flags: $known_opts" + } + set opts [dict merge $defaults $args] + if {[dict get $opts -note] eq "\uFFFF"} { + dict unset opts -note + } + + + set status [string toupper $status] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + if {$o_operation_start_ts eq ""} { + error "[self] targetset_end $status - no current operation - call targetset_started first" + } + if {$status ni [dict keys $statusdict]} { + error "[self] targetset_end unrecognized status:$status known values: [dict keys $statusdict]" + } + if {![punkcheck::lib::is_file_record_inprogress $o_fileset_record]} { + error "targetset_end $status error: bad fileset_record - expected FILEINFO with last body element *-INPROGRESS" + } + set targetlist [dict get $o_fileset_record -targets] + if {$targetlist ne $o_targets} { + error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" + } + set operation_end_ts [clock microseconds] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set file_record_body [dict get $o_fileset_record body] + set installing_record [lindex $file_record_body end] + set punkcheck_file [$o_installer get_checkfile] + set record_list [punkcheck::load_records_from_file $punkcheck_file] + if {[dict exists $installing_record -ts_start_transfer]} { + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set transfer_us [expr {$operation_end_ts - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + } + if {[dict exists $opts -note]} { + dict set installing_record -note [dict get $opts -note] + } + + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "${o_operation}-[dict get $statusdict $status]" ;# e.g INSTALL-RECORD, INSTALL-SKIPPED + lset file_record_body end $installing_record + dict set o_fileset_record body $file_record_body + set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $o_fileset_record + } else { + lset record_list $old_posn $o_fileset_record + } + punkcheck::save_records_to_file $record_list $punkcheck_file + set o_operation_start_ts "" + set o_operation "" + return $o_fileset_record + } + method targetset_addsource {source_path} { + set punkcheck_file [$o_installer get_checkfile] + set punkcheck_folder [file dirname $punkcheck_file] + if {[file pathtype $source_path] eq "absolute"} { + set rel_source_path [punkcheck::lib::path_relative $punkcheck_folder $source_path] + } else { + set rel_source_path $source_path + } + + set o_fileset_record [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $rel_source_path $o_fileset_record] + + } + method targetset_source_changes {} { + punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $o_fileset_record body] end] + } + + } + + + oo::class create installtrack { + variable o_name + variable o_tsiso + variable o_ts + variable o_keep_events + variable o_checkfile + variable o_sourceroot + variable o_rel_sourceroot + variable o_targetroot + variable o_rel_targetroot + variable o_record_list + variable o_active_event + variable o_events + constructor {installername punkcheck_file} { + set o_active_event "" + set o_name $installername + + set o_checkfile [file normalize $punkcheck_file] + set o_sourceroot "" + set o_targetroot "" + set o_rel_sourceroot "" + set o_rel_targetroot "" + #todo - validate punkcheck file location further?? + set punkcheck_folder [file dirname $o_checkfile] + if {![file isdirectory $punkcheck_folder]} { + error "[self] constructor error. Folder for punkcheck_file not found - $o_checkfile" + } + + my load_all_records + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $o_name] + set o_record_list [linsert $o_record_list 0 $this_installer_record] + } else { + set this_installer_record [dict get $resultinfo record] + } + set o_tsiso [dict get $this_installer_record -tsiso] + set o_ts [dict get $this_installer_record -ts] + set o_keep_events [dict get $this_installer_record -keep_events] + + set o_events [oolib::collection create [namespace current]::eventcollection] + set eventlist [punkcheck::dict_getwithdefault $this_installer_record body [list]] + foreach e $eventlist { + set eobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] [dict get $e -source] [dict get $e -targets] {*}$e] + #$o_events add $e [dict get $e -id] + $o_events add $eobj [dict get $e -id] + } + + } + destructor { + #puts "[self] destructor called" + } + method test {} { + return [self] + } + method get_name {} { + return $o_name + } + method get_checkfile {} { + return $o_checkfile + } + + #call set_source_target before calling start_event/end_event + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + method set_source_target {sourceroot targetroot} { + if {[file pathtype $sourceroot] ne "absolute"} { + error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" + } + if {[file pathtype $targetroot] ne "absolute"} { + error "[self] set_source_target error: targetroot must be absolute path. Received '$targetroot'" + } + set punkcheck_folder [file dirname $o_checkfile] + set o_sourceroot $sourceroot + set o_targetroot $targetroot + set o_rel_sourceroot [punkcheck::lib::path_relative $punkcheck_folder $sourceroot] + set o_rel_targetroot [punkcheck::lib::path_relative $punkcheck_folder $targetroot] + return [list $o_rel_sourceroot $o_rel_targetroot] + } + #review/fix to allow multiple installtrack objects on same punkcheck file. + method load_all_records {} { + set o_record_list [punkcheck::load_records_from_file $o_checkfile] + } + + #does not include associated FILEINFO records - as a targetset (FILEINFO record) can be associated with events from multiple installers over time. + #e.g a logfile common to installers, or a separate installer that updates a previous output. + method as_record {} { + set eventrecords [list] + foreach eobj [my events items] { + lappend eventrecords [$eobj as_record] + } + set fields [list\ + -tsiso $o_tsiso\ + -ts $o_ts\ + -name $o_name\ + -keep_events $o_keep_events\ + body $eventrecords\ + ] + set record [dict create tag INSTALLER {*}$fields] + } + #open file and save only own records + method save_all_records {} { + my save_installer_record + #todo - save FILEINFO targetset records + } + method save_installer_record {} { + set file_records [punkcheck::load_records_from_file $o_checkfile] + + set this_installer_record [my as_record] + + set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] + set existing_header_posn [dict get $persistedinfo position] + if {$existing_header_posn == -1} { + set file_records [linsert $file_records 0 $this_installer_record] + } else { + lset file_records $existing_header_posn $this_installer_record + } + punkcheck::save_records_to_file $file_records $o_checkfile + } + method events {args} { + tailcall $o_events {*}$args + } + method start_event {configdict} { + if {$o_active_event ne ""} { + error "[self] start_event error - event already started: $o_active_event" + } + if {$o_rel_sourceroot eq "" || $o_rel_targetroot eq ""} { + error "[self] No configured sourceroot or targetroot. Call [self] set_source_target first" + } + + if {[llength $configdict] %2 != 0} { + error "[self] new_event configdict must have an even number of elements" + } + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + error "[self] start_event - installer record missing. installer: $o_name" + } else { + set this_installer_record [dict get $resultinfo record] + } + + set eventobj [punkcheck::installevent create [namespace current]::event_[my events count] [self] $o_rel_sourceroot $o_rel_targetroot -config $configdict] + set eventid [$eventobj get_id] + set event_record [$eventobj as_record] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $o_record_list] + + #replace + lset o_record_list $existing_header_posn $this_installer_record + + punkcheck::save_records_to_file $o_record_list $o_checkfile + set o_active_event $eventobj + my events add $eventobj $eventid + return $eventobj + } + method installer_record_from_file {} { + set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] + } + method get_recordlist {} { + return $o_recordlist + } + method end_event {} { + if {$o_active_event eq ""} { + error "[self] end_event error - no active event" + } + $o_active_event end + } + method get_event {} { + return $o_active_event + } + if 0 { + method unknown {args} { + puts "[self] unknown called with args:$args" + if {[llength $args]} { + + } else { + + } + } + } + } + } + proc start_installer_event {punkcheck_file installername from_fullpath to_fullpath config} { + set eventid [punkcheck::uuid] + if {[file pathtype $from_fullpath] ne "absolute"} { + error "start_installer_event error: from_fullpath must be absolute path. Received '$from_fullpath'" + } + if {[file pathtype $to_fullpath] ne "absolute"} { + error "start_installer_event error: to_fullpath must be absolute path. Received '$to_fullpath'" + } + set punkcheck_folder [file dirname $punkcheck_file] + set rel_source [punkcheck::lib::path_relative $punkcheck_folder $from_fullpath] + set rel_target [punkcheck::lib::path_relative $punkcheck_folder $to_fullpath] + + + set record_list [punkcheck::load_records_from_file $punkcheck_file] + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set existing_header_posn [dict get $resultinfo position] + if {$existing_header_posn == -1} { + set this_installer_record [punkcheck::recordlist::new_installer_record $installername] + } else { + set this_installer_record [dict get $resultinfo record] + } + + set event_record [punkcheck::recordlist::new_installer_event_record install\ + -id $eventid\ + -source $rel_source\ + -targets $rel_target\ + -config $config\ + ] + + set this_installer_record [punkcheck::recordlist::installer_record_add_event $this_installer_record $event_record] + set this_installer_record [punkcheck::recordlist::installer_record_pruneevents $this_installer_record $record_list] + + if {$existing_header_posn == -1} { + #not found - prepend + set record_list [linsert $record_list 0 $this_installer_record] + } else { + #replace + lset record_list $existing_header_posn $this_installer_record + } + + punkcheck::save_records_to_file $record_list $punkcheck_file + return [list eventid $eventid recordset $record_list] + } + #----------------------------------------------- + proc installfile_help {} { + set msg "" + append msg "Call in order:" \n + append msg " start_installer_event (get dict with eventid and recordset keys)" + append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " ( - possibly with same algorithm as previous installrecord)" \n + append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n + append msg "Finalize by calling:" \n + append msg " installfile_started_install" \n + append msg " (install the file e.g file copy)" \n + append msg " installfile_finished_install" \n + append msg " OR" \n + append msg " installfile_skipped_install" \n + } + proc installfile_begin {punkcheck_folder target_relpath installername args} { + if {[llength $args] %2 !=0} { + error "punkcheck installfile_begin args must be name-value pairs" + } + set target_relpath [lsort -dictionary -increasing $target_relpath] ;#exact sort order not critical - but must be consistent + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -installer $installername\ + -eventid unspecified\ + ] + set opts [dict merge $defaults $args] + set opt_eventid [dict get $opts -eventid] + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] + set installer_record_position [dict get $resultinfo position] + if {$installer_record_position == -1} { + error "installfile_begin error: Failed to retrieve installer record for installer name:'$installername' - ensure start_installer_event has been called with same installer, and -eventid is passed to installfile_begin" + } + set this_installer_record [dict get $resultinfo record] + set events [dict get $this_installer_record body] + set active_event [list] + foreach evt [lreverse $events] { + if {[dict get $evt -id] eq $opt_eventid} { + set active_event $evt + break + } + } + if {![llength $active_event]} { + error "installfile_begin error: eventid $opt_eventid not found for installer '$installername' - aborting" + } + + + set extractioninfo [punkcheck::recordlist::extract_or_create_fileset_record $target_relpath $record_list] + set file_record [dict get $extractioninfo record] + set record_list [dict get $extractioninfo recordset] + set isnew [dict get $extractioninfo isnew] + set oldposition [dict get $extractioninfo oldposition] + unset extractioninfo + + #INSTALL-INPROGRESS will become INSTALL-RECORD or INSTALL-FAILED or INSTALL-SKIPPED upon finalisation + #-installer and -eventid keys are added here + set new_installing_record [dict create tag INSTALL-INPROGRESS {*}$opts -tempcontext $active_event body {}] + #set existing_body [dict_getwithdefault $file_record body [list]] + #todo - look for existing "INSTALL-INPROGRESS" records - mark as failed? + dict lappend file_record body $new_installing_record + + if {$isnew} { + lappend record_list $file_record + } else { + set record_list [linsert $record_list[unset record_list] $oldposition $file_record] + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + + #todo - ensure that removing a dependency is noticed as a change + #e.g previous installrecord had 2 source records - but we now only depend on one. + #The files we depended on for the previous record haven't changed themselves - but the list of files has (reduced by one) + proc installfile_add_source_and_fetch_metadata {punkcheck_folder source_relpath file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_add_source_and_fetch_metdata error: bad file_record - expected FILEINFO with last body element *-INPROGRESS ($file_record)" + } + set ts_start [clock microseconds] + set last_installrecord [lib::file_record_get_last_installrecord $file_record] + set prev_ftype "" + set prev_fsize "" + set prev_cksum "" + set prev_cksum_opts "" + if {[llength $last_installrecord]} { + set src [lib::install_record_get_matching_source_record $last_installrecord $source_relpath] + if {[llength $src]} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + set prev_ftype [dict_getwithdefault $src -type ""] + set prev_fsize [dict_getwithdefault $src -size ""] + set prev_cksum [dict_getwithdefault $src -cksum ""] + set prev_cksum_opts [dict_getwithdefault $src -cksum_all_opts ""] + } + } + } + #check that this relpath not already added as child of *-INPROGRESS + set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body + set installing_record [lindex $file_record_body end] + set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] + if {[llength $already_present_record]} { + error "installfile_add_source_and_fetch_metadata error: source path $source_relpath already exists in the file_record - cannot add again" + } + + if {$prev_cksum_opts ne ""} { + set cksum_opts $prev_cksum_opts + } else { + set cksum_opts "" + } + #allow nonexistant as a source + set fpath [file join $punkcheck_folder $source_relpath] + if {![file exists $fpath]} { + set ftype "missing" + set fsize "" + #get_relativecksum_from_base will set cksum to + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + } else { + set ftype [file type $fpath] + if {$ftype eq "directory"} { + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + set fsize "NA" + } else { + #todo - optionally use mtime instead of cksum (for files only)? + #mtime is not reliable across platforms and filesystems though.. see article linked at toop. + set source_cksum_info [punk::mix::base::lib::get_relativecksum_from_base $punkcheck_folder $source_relpath {*}$cksum_opts] + set fsize [file size $fpath] + } + } + + + lassign $source_cksum_info pathkey ckinfo + if {$pathkey ne $source_relpath} { + error "installfile_add_source_and_fetch_metadata error: cksum returned wrong path info '$pathkey' expected '$source_relpath'" + } + set cksum [dict get $ckinfo cksum] + set cksum_all_opts [dict get $ckinfo cksum_all_opts] + if {$cksum ne $prev_cksum || $ftype ne $prev_ftype || $fsize ne $prev_fsize} { + set changed 1 + } else { + set changed 0 + } + set installing_record_sources [dict_getwithdefault $installing_record body [list]] + set ts_now [clock microseconds] ;#gathering metadata - especially checsums on folder can take some time - calc and store elapsed us for time taken to gather metadata + set metadata_us [expr {$ts_now - $ts_start}] + set this_source_record [dict create tag SOURCE -type $ftype -size $fsize -path $source_relpath -cksum $cksum -cksum_all_opts $cksum_all_opts -changed $changed -metadata_us $metadata_us] + lappend installing_record_sources $this_source_record + dict set installing_record body $installing_record_sources + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + return $file_record + } + + #write back to punkcheck - don't accept recordset - invalid to update anything other than the installing_record at this time + proc installfile_started_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_started_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_now [clock microseconds] + set metadata_us [expr {$ts_now - $ts_start}] + + dict set installing_record -metadata_us $metadata_us + dict set installing_record -ts_start_transfer $ts_now + + lset file_record_body end $installing_record + + dict set file_record body $file_record_body + + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + proc installfile_finished_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + error "installfile_finished_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set ts_start_transfer [dict get $installing_record -ts_start_transfer] + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + set transfer_us [expr {$ts_now - $ts_start_transfer}] + dict set installing_record -transfer_us $transfer_us + dict set installing_record -elapsed_us $elapsed_us + dict unset installing_record -tempcontext + dict set installing_record tag "INSTALL-RECORD" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $oldrecordinfo position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + proc installfile_skipped_install {punkcheck_folder file_record} { + if {![lib::is_file_record_inprogress $file_record]} { + set msg "installfile_skipped_install error: bad file_record - expected FILEINFO with last body element *-INPROGRESS" + append msg \n "received:" + append msg \n $file_record + error $msg + } + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + set record_list [load_records_from_file $punkcheck_file] + + set file_record_body [dict get $file_record body] + set targetlist [dict get $file_record -targets] + set installing_record [lindex $file_record_body end] + + set ts_start [dict get $installing_record -ts] + set tsnow [clock microseconds] + set elapsed_us [expr {$tsnow - $ts_start}] + dict set installing_record -elapsed_us $elapsed_us + dict set installing_record tag "SKIPPED" + + lset file_record_body end $installing_record + dict set file_record body $file_record_body + + set file_record [punkcheck::recordlist::file_record_prune $file_record] + + set getresult [punkcheck::recordlist::get_file_record $targetlist $record_list] + set old_posn [dict get $getresult position] + if {$old_posn == -1} { + lappend record_list $file_record + } else { + lset record_list $old_posn $file_record + } + + save_records_to_file $record_list $punkcheck_file + return $file_record + } + #----------------------------------------------- + #then: file_record_add_installrecord + + namespace eval lib { + namespace path ::punkcheck + proc is_file_record_inprogress {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ni [list INSTALL-INPROGRESS MODIFY-INPROGRESS DELETE-INPROGRESS VIRTUAL-INPROGRESS]} { + return 0 + } + return 1 + } + proc is_file_record_installing {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + return 0 + } + set installing_record [lindex [dict_getwithdefault $file_record body [list]] end] + if {[dict_getwithdefault $installing_record tag [list]] ne "INSTALL-INPROGRESS"} { + return 0 + } + return 1 + } + proc file_record_get_last_installrecord {file_record} { + set body [dict_getwithdefault $file_record body [list]] + set previous_install_records [lrange $body 0 end-1] + #get last previous that is tagged INSTALL-RECORD,MODIFY-RECORD,VIRTUAL-RECORD + #REVIEW DELETERECORD ??? + set revlist [lreverse $previous_install_records] + foreach rec $revlist { + if {[dict get $rec tag] in [list "INSTALL-RECORD" "MODIFY-RECORD" "VIRTUAL-RECORD"]} { + return $rec + } + } + return [list] + } + + #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL + proc install_record_get_matching_source_record {install_record source_relpath} { + set body [dict_getwithdefault $install_record body [list]] + foreach src $body { + if {[dict get $src tag] eq "SOURCE"} { + if {[dict_getwithdefault $src -path ""] eq $source_relpath} { + return $src + } + } + } + return [list] + } + + + + #maint warning - also in punk::mix::util + proc path_relative {base dst} { + #see also kettle + # Modified copy of ::fileutil::relative (tcllib) + # Adapted to 8.5 ({*}). + # + # Taking two _directory_ paths, a base and a destination, computes the path + # of the destination relative to the base. + # + # Arguments: + # base The path to make the destination relative to. + # dst The destination path + # + # Results: + # The path of the destination, relative to the base. + + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + #review - check volume info on windows.. UNC paths? + if {[file pathtype $base] ne [file pathtype $dst]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + #avoid normalizing if possible - at least for relative paths which we are likely to loop on (file normalize *very* expensive on windows) + set do_normalize 0 + if {[file pathtype $base] eq "relative"} { + #if base is relative so is dst + if {[regexp {[.]{2}} [list $base $dst]]} { + set do_normalize 1 + } + if {[regexp {[.]/} [list $base $dst]]} { + set do_normalize 1 + } + } else { + #case differences in volumes is common on windows + set do_normalize 1 + } + if {$do_normalize} { + set base [file normalize $base] + set dst [file normalize $dst] + } + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[lindex $dst 0] eq [lindex $base 0]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + set dst [file join {*}$dst] + } + + return $dst + } + } + #skip writing punkcheck during checksum/timestamp checks + + proc install_tm_files {srcdir basedir args} { + set defaults [list\ + -glob *.tm\ + -antiglob_file [list "*[punk::mix::util::magic_tm_version]*"]\ + -installer punkcheck::install_tm_files\ + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + proc install_non_tm_files {srcdir basedir args} { + #set keys [dict keys $args] + set defaults [list\ + -glob *\ + -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"]\ + -installer punkcheck::install_non_tm_files\ + ] + set opts [dict merge $defaults $args] + punkcheck::install $srcdir $basedir {*}$opts + } + + #for tcl8.6 - tcl8.7+ has dict getwithdefault (dict getdef) + proc dict_getwithdefault {dictValue args} { + if {[llength $args] < 2} { + error {wrong # args: should be "dict_getdef dictionary ?key ...? key default"} + } + set keys [lrange $args 0 end-1] + if {[dict exists $dictValue {*}$keys]} { + return [dict get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + proc pathglob_as_re {glob} { + #any segment that is not just * must match exactly one segment in the path + set pats [list] + foreach seg [file split $glob] { + if {$seg eq "*"} { + lappend pats {[^/]*} + } elseif {$seg eq "**"} { + lappend pats {.*} + } else { + set seg [string map [list . {[.]}] $seg] + if {[regexp {[*?]} $seg]} { + set pat [string map [list * {[^/]*} ? {[^/]}] $seg] + lappend pats "$pat" + } else { + lappend pats "$seg" + } + } + } + return "^[join $pats /]\$" + } + proc globmatchpath {glob path} { + return [regexp [pathglob_as_re $glob] $path] + } + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # -overwrite installedsourcechanged-targets + # review - timestamps unreliable + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + # REVIEW we should only expect dirs to be created as necessary to hold files? i.e target folder won't be created if no source file matches for that folder + # -source_checksum compare|store|comparestore|false|true where true == comparestore + # -punkcheck_folder target|source|project| target is default and is generally recommended + # -punkcheck_records empty string | parsed TDL records ie {tag xxx k v} structure + proc install {srcdir tgtdir args} { + set defaults [list\ + -call-depth-internal 0\ + -max_depth 1000\ + -subdirlist {}\ + -glob *\ + -antiglob_file_core "\uFFFF"\ + -antiglob_file "" \ + -antiglob_dir_core "\uFFFF"\ + -antiglob_dir {}\ + -unpublish_paths {}\ + -overwrite no-targets\ + -source_checksum comparestore\ + -punkcheck_folder target\ + -punkcheck_eventid "\uFFFF"\ + -punkcheck_records ""\ + -installer punkcheck::install\ + ] + + set opts [dict merge $defaults $args] + if {([llength $args] %2) != 0} { + error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args" + } + foreach k [dict keys $args] { + if {$k ni [dict keys $defaults]} { + error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0 + set max_depth [dict get $opts -max_depth] + set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill + set fileglob [dict get $opts -glob] + + if {$CALLDEPTH == 0} { + #expensive to normalize but we need to do it at least once + set srcdir [file normalize $srcdir] + set tgtdir [file normalize $tgtdir] + #now the values we build from these will be properly cased + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_file_core [dict get $opts -antiglob_file_core] + if {$opt_antiglob_file_core eq "\uFFFF"} { + set opt_antiglob_file_core [default_antiglob_file_core] + dict set opts -antiglob_file_core $opt_antiglob_file_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_file [dict get $opts -antiglob_file] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] + if {$opt_antiglob_dir_core eq "\uFFFF"} { + set opt_antiglob_dir_core [default_antiglob_dir_core] + dict set opts -antiglob_dir_core $opt_antiglob_dir_core + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_antiglob_dir [dict get $opts -antiglob_dir] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_unpublish_paths [dict get $opts -unpublish_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) + set unpublish_paths_matched [list] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "punkcheck::install received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + if {$overwrite_what in [list newer-targets older-targets]} { + error "punkcheck::install newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_source_checksum [dict get $opts -source_checksum] + if {[string is boolean $opt_source_checksum]} { + if {$opt_source_checksum} { + set opt_source_checksum "comparestore" + } else { + set opt_source_checksum 0 + } + dict set opts -source_checksum $opt_source_checksum + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_folder [dict get $opts -punkcheck_folder] + if {$opt_punkcheck_folder eq "target"} { + set punkcheck_folder $tgtdir + } elseif {$opt_punkcheck_folder eq "source"} { + set punkcheck_folder $srcdir + } elseif {$opt_punkcheck_folder eq "project"} { + set sourceprojectinfo [punk::repo::find_repos $srcdir] + set targetprojectinfo [punk::repo::find_repos $tgtdir] + set srcproj [lindex [dict get $sourceprojectinfo project] 0] + set tgtproj [lindex [dict get $targetprojectinfo project] 0] + if {$srcproj eq $tgtproj} { + set punkcheck_folder $tgtproj + } else { + error "copy_files_from_source_to_target error: Unable to find common project dir for source and target folder - use absolutepath for -punkcheck_folder if source and target are not within same project" + } + } else { + set punkcheck_folder $opt_punkcheck_folder + } + if {$punkcheck_folder ne ""} { + if {[file pathtype $punkcheck_folder] ne "absolute"} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' must be an absolute path, or one of: target|source|project" + } + if {![file isdirectory $punkcheck_folder]} { + error "copy_files_from_source_to_target error: -punkcheck_folder '$punkcheck_folder' not found" + } + } else { + #review - leave empty? use pwd? + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set punkcheck_records [dict get $opts -punkcheck_records] + set punkcheck_records_init $punkcheck_records ;#change-detection + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_installer [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventid [dict get $opts -punkcheck_eventid] + + + + set punkcheck_file [file join $punkcheck_folder/.punkcheck] + + if {$CALLDEPTH == 0} { + set punkcheck_eventid "" + if {$punkcheck_folder ne ""} { + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } + lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records + } + } else { + set punkcheck_eventid $opt_punkcheck_eventid + } + + + + if {$opt_source_checksum != 0} { + #we need to read the file even if only set to store (or we would overwrite entries) + set compare_cksums 1 + } else { + set compare_cksums 0 + } + + if {[string match *store* $opt_source_checksum]} { + set store_cksums 1 + } else { + set store_cksums 0 + } + + + + + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } + foreach unpub $opt_unpublish_paths { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[globmatchpath $unpub $relative_source_dir]} { + lappend unpublish_paths_matched $current_source_dir + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched] + } + } + + + if {![file exists $current_source_dir]} { + error "copy_files_from_source_to_target current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {![file exists $current_target_dir]} { + error "copy_files_from_source_to_target current target dir:'$current_target_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {([file type $current_source_dir] ni [list directory]) || ([file type $current_target_dir] ni [list directory])} { + error "copy_files_from_source_to_target requires source and target dirs to be of type 'directory' type current source: [file type $current_source_dir] type current target: [file type $current_target_dir]" + } + + set files_copied [list] + set files_skipped [list] + set sources_unchanged [list] + + + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti [concat $opt_antiglob_file_core $opt_antiglob_file] { + if {[string match $anti $m]} { + #puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + #sample .punkcheck file record (raw form) to make the code clearer + #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + # + #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { + # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3423 + # SOURCE -type file -path ../src/modules/jjjetc-999999.0a1.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 1 -metadata_us 3413 + # } + # INSTALL-SKIPPED -tsiso 2023-09-20T08:14:26 -ts 1695161666087880 -installer punk::mix::cli::build_modules_from_source_to_base -elapsed_us 18914 { + # SOURCE -type file -path ../src/modules/jjjetc-buildversion.txt -cksum c7c71839c36b3d21c8370fed106192fcd659eca9 -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3435 + # SOURCE -type file -path ../src/modules/jjjetc-999999.0a1.0.tm -cksum b646fc2ee88cbd068d2e946fe929b7aea96bd39d -cksum_all_opts {-cksum_content 1 -cksum_meta 0 -cksum_acls 0 -cksum_usetar 0 -cksum_algorithm sha1} -changed 0 -metadata_us 3338 + # } + #} + + + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} + + + #puts stdout "Current target dir: $current_target_dir" + foreach m $match_list { + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] + set is_unpublished 0 + foreach unpub $opt_unpublish_paths { + #puts "testing file - globmatchpath $unpub vs $relative_source_path" + if {[globmatchpath $unpub $relative_source_path]} { + lappend unpublish_paths_matched $current_source_dir + set is_unpublished 1 + break + } + } + if {$is_unpublished} { + continue + } + #puts stdout " checking file : $current_source_dir/$m" + set ts_start [clock microseconds] + set seconds [expr {$ts_start / 1000000}] + set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + + #puts stdout " rel_target: $punkcheck_target_relpath" + + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] + #change to use extract_or_create_fileset_record ? + set existing_filerec_posn [dict get $fetch_filerec_result position] + if {$existing_filerec_posn == -1} { + puts stdout "NO existing record for $punkcheck_target_relpath" + set has_filerec 0 + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] + set filerec $new_filerec + } else { + set has_filerec 1 + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" + #puts stdout " $existing_install_record" + set filerec [dict get $fetch_filerec_result record] + } + set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] + + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method + set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] + dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. + unset new_install_record + + + + + + set relative_source_path [lib::path_relative $punkcheck_folder $current_source_dir/$m] + #puts stdout " rel_source: $relative_source_path" + if {[file pathtype $relative_source_path] ne "relative"} { + #different volume or root + } + #Note this isn't a recordlist function - so it doesn't purely operate on the records + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) + set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] + + set changeinfo [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $filerec body] end]] + set changed [dict get $changeinfo changed] + set unchanged [dict get $changeinfo unchanged] + if {[llength $unchanged]} { + lappend sources_unchanged $current_source_dir/$m + } + + set is_skip 0 + if {$overwrite_what eq "all-targets"} { + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + if {![file exists $current_target_dir/$m]} { + file copy $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + incr filecount_new + } else { + if {$overwrite_what eq "installedsourcechanged-targets"} { + if {[llength $changed]} { + #An unrecorded installation is considered a source change (from unknown/unrecorded source to recorded) + file copy -force $current_source_dir/$m $current_target_dir + lappend files_copied $current_source_dir/$m + } else { + set is_skip 1 + lappend files_skipped $current_source_dir/$m + } + } else { + set is_skip 1 + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets + lappend files_skipped $current_source_dir/$m + } + } + } + + + set ts_now [clock microseconds] + set elapsed_us [expr {$ts_now - $ts_start}] + + if {$store_cksums} { + + set install_records [dict get $filerec body] + set current_install_record [lindex $install_records end] + #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED + if {$is_skip} { + set tag INSTALL-SKIPPED + } else { + set tag INSTALL-RECORD + } + dict set current_install_record tag $tag + dict set current_install_record -elapsed_us $elapsed_us + lset install_records end $current_install_record + dict set filerec body $install_records + set filerec [punkcheck::recordlist::file_record_prune $filerec] ;#prune now that tag is finalized + if {!$has_filerec} { + #not found in original recordlist - append + lappend punkcheck_records $filerec + } else { + lset punkcheck_records $existing_filerec_posn $filerec + } + } + + } + + if {$CALLDEPTH >= $max_depth} { + #don't process any more subdirs + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + if {$h in [list "." ".."]} { + continue + } + if {$h ni $subdirs} { + lappend subdirs $h + } + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipd 0 + foreach dg [concat $opt_antiglob_dir_core $opt_antiglob_dir] { + if {[string match $dg $d]} { + puts stdout "SKIPPING FOLDER $d due to antiglob_dir-match: $dg " + set skipd 1 + break + } + } + if {$skipd} { + continue + } + + + if {![file exists $current_target_dir/$d]} { + file mkdir $current_target_dir/$d + } + + + set sub_opts_1 [list\ + -call-depth-internal [expr {$CALLDEPTH + 1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -glob $fileglob\ + -antiglob_file_core $opt_antiglob_file_core\ + -antiglob_file $opt_antiglob_file\ + -antiglob_dir_core $opt_antiglob_dir_core\ + -antiglob_dir $opt_antiglob_dir\ + -overwrite $overwrite_what\ + -source_checksum $opt_source_checksum\ + -punkcheck_folder $punkcheck_folder\ + -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_records $punkcheck_records\ + -installer $opt_installer\ + ] + set sub_opts [list\ + -call-depth-internal [expr {$CALLDEPTH + 1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_folder $punkcheck_folder\ + -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_records $punkcheck_records\ + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] + + lappend files_copied {*}[dict get $sub_result files_copied] + lappend files_skipped {*}[dict get $sub_result files_skipped] + lappend sources_unchanged {*}[dict get $sub_result sources_unchanged] + lappend unpublish_paths_matched {*}[dict get $sub_result unpublish_paths_matched] + set punkcheck_records [dict get $sub_result punkcheck_records] + } + + if {[string match *store* $opt_source_checksum]} { + #puts "subdirlist: $subdirlist" + if {$CALLDEPTH == 0} { + if {[llength $files_copied] || [llength $files_skipped]} { + puts stdout ">>>>>>>>>>>>>>>>>>>" + set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file] + puts stdout "[dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file" + puts stdout "copied: [llength $files_copied] skipped: [llength $files_skipped]" + puts stdout ">>>>>>>>>>>>>>>>>>>" + } else { + #todo - write db INSTALLER record if -debug true + + } + #puts stdout "sources_unchanged" + #puts stdout "$sources_unchanged" + #puts stdout "- -- --- --- --- ---" + } + } + + return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged unpublish_paths_matched $unpublish_paths_matched punkcheck_records $punkcheck_records] + } + + namespace eval recordlist { + namespace path ::punkcheck + + proc records_as_target_dict {record_list} { + set result [dict create] + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + set tgtlist [dict get $rec -targets] + dict set result $tgtlist $rec + } + } + return $result + } + + + + + #will only match if same base was used.. and same targetlist + proc get_file_record {targetlist record_list} { + set posn 0 + set found_posn -1 + set record "" + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict get $rec -targets] eq $targetlist} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + proc file_install_record_source_changes {install_record} { + #reject INSTALLFAILED items ? + if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED" "INSTALL-INPROGRESS" "MODIFY-INPROGRESS" "MODIFY-RECORD" "VIRTUAL-INPROGRESS" "VIRTUAL-RECORD" "DELETE-RECORD" "DELETE-INPROGRESS"]} { + error "file_install_record_source_changes bad file->install record: tag not INSTALL-RECORD|SKIPPED|INSTALL-INPROGRESS|MODIFY-RECORD|MODIFY-INPROGRESS|VIRTUAL-RECORD|VIRTUAL-INPROGRESS|DELETE-RECORD|DELETE-INPROGRESS" + } + set source_list [dict_getwithdefault $install_record body [list]] + set changed [list] + set unchanged [list] + foreach src $source_list { + if {[dict exists $src -changed]} { + if {[dict get $src -changed] !=0} { + lappend changed [dict get $src -path] + } else { + lappend unchanged [dict get $src -path] + } + } else { + lappend changed [dict get $src -path] + } + } + return [dict create changed $changed unchanged $unchanged] + } + + #assume only one for name - use first encountered + proc get_installer_record {name record_list} { + set posn 0 + set found_posn -1 + set record "" + #puts ">>>> checking [llength $record_list] punkcheck records" + foreach rec $record_list { + if {[dict get $rec tag] eq "INSTALLER"} { + if {[dict get $rec -name] eq $name} { + set found_posn $posn + set record $rec + break + } + } + incr posn + } + return [list position $found_posn record $record] + } + + proc new_installer_record {name args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + + #put -tsiso first so it lines up with -tsiso in event records + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -name $name\ + -keep_events 5\ + ] + set opts [dict merge $defaults $args] + + #set this_installer_record_list [punk::tdl::prettyparse [list INSTALLER name $opt_installer ts $ts tsiso $tsiso keep_events 5 {}]] + #set this_installer_record [lindex $this_installer_record_list 0] + + set record [dict create tag INSTALLER {*}$opts body {}] + + + return $record + } + proc new_installer_event_record {type args} { + if {[llength $args] %2 !=0} { + error "punkcheck new_installer_event_record args must be name-value pairs" + } + set ts [clock microseconds] + set seconds [expr {$ts / 1000000}] + set tsiso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] + set defaults [list\ + -tsiso $tsiso\ + -ts $ts\ + -type $type\ + ] + set opts [dict merge $defaults $args] + + set record [dict create tag EVENT {*}$opts] + } + #need to scan entire set if filerecords to check if event is still referenced + proc installer_record_pruneevents {installer_record record_list} { + set keep 5 + if {[dict exists $installer_record -keep_events]} { + set keep [dict get $installer_record -keep_events] + } + + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "EVENT"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } else { + set eventid "" + if {[dict exists $item -id]} { + set eventid [dict get $item -id] + } + if {$eventid ne "" && $eventid ne "unspecified"} { + #keep if referenced, discard if not, or if eventid empty/unspecified + set is_referenced 0 + foreach rec $record_list { + if {[dict get $rec tag] eq "FILEINFO"} { + if {[dict exists $rec body]} { + foreach install [dict get $rec body] { + if {[dict exists $install -eventid] && [dict get $install -eventid] eq $eventid} { + set is_referenced 1 + break + } + } + } + } + if {$is_referenced} { + break + } + } + if {$is_referenced} { + lappend kept_body_items $item + } + } + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set installer_record body $kept_body_items + return $installer_record + } + proc installer_record_add_event {installer_record event} { + if {[dict get $installer_record tag] ne "INSTALLER"} { + error "installer_record_add_event bad installer record: tag not INSTALLER" + } + if {[dict get $event tag] ne "EVENT"} { + error "installer_record_add_event bad event record: tag not EVENT" + } + if {[dict exists $installer_record body]} { + set body_items [dict get $installer_record body] + } else { + set body_items [list] + } + lappend body_items $event + dict set installer_record body $body_items + return $installer_record + } + proc file_record_latest_installrecord {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_latest_installrecord bad file_record: tag not FILEINFO" + } + if {![dict exists $file_record body]} { + return [list] + } + set body_items [dict get $file_record body] + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "INSTALL-RECORD"} { + return $item + } + } + return [list] + } + + + #dead code? + proc file_record_add_installrecordXXX {file_record install_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_add_installrecord bad file_record: tag not FILEINFO" + } + #disallow '-INPROGRESS' as it's not a final tag + if {[dict get $install_record tag] ni [list "INSTALL-RECORD" "SKIPPED"]} { + error "file_record_add_installrecord bad install_record: tag not INSTALL-RECORD" + } + set keep 3 + if {[dict exists $file_record -keep_installrecords]} { + set keep [dict get $file_record -keep_installrecords] + } + + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + lappend body_items $install_record + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[dict get $item tag] eq "INSTALL-RECORD"} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + + dict set file_record body $kept_body_items + return $file_record + + + } + + + proc file_record_set_defaults {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_set_defaults bad file_record: tag not FILEINFO" + } + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + dict for {k v} $defaults { + if {![dict exists $file_record $k]} { + dict set file_record $k $v + } + } + return $file_record + } + + #negative keep_ value will keep all + proc file_record_prune {file_record} { + if {[dict get $file_record tag] ne "FILEINFO"} { + error "file_record_prune bad file_record: tag not FILEINFO" + } + set file_record [file_record_set_defaults $file_record] + set kmap [list -keep_installrecords *-RECORD -keep_skipped *-SKIPPED -keep_inprogress *-INPROGRESS] + foreach {key rtype} $kmap { + set keep [dict get $file_record $key] + if {[dict exists $file_record body]} { + set body_items [dict get $file_record body] + } else { + set body_items [list] + } + set kept_body_items [list] + set kcount 0 + foreach item [lreverse $body_items] { + if {[string match $rtype [dict get $item tag]]} { + incr kcount + if {$keep < 0 || $kcount <= $keep} { + lappend kept_body_items $item + } + } else { + lappend kept_body_items $item + } + } + set kept_body_items [lreverse $kept_body_items] + dict set file_record body $kept_body_items + } + return $file_record + } + + #extract new or existing filerecord for path given + #review - locking/concurrency + proc extract_or_create_fileset_record {relative_target_paths recordset} { + set fetch_record_result [punkcheck::recordlist::get_file_record $relative_target_paths $recordset] + set existing_posn [dict get $fetch_record_result position] + if {$existing_posn == -1} { + #puts stdout "NO existing record for $relative_target_paths" + set isnew 1 + set fileset_record [dict create tag FILEINFO -targets $relative_target_paths body {}] + } else { + set recordset [lreplace $recordset[unset recordset] $existing_posn $existing_posn] + set isnew 0 + set fileset_record [dict get $fetch_record_result record] + } + return [list record $fileset_record recordset $recordset isnew $isnew oldposition $existing_posn] + } + + } + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punkcheck [namespace eval punkcheck { + variable version + set version 0.1.0 +}] +return diff --git a/src/modules/punk/mix/templates/layouts/project/src/build.tcl b/src/modules/punk/mix/templates/layouts/project/src/build.tcl index 2addab4b..ee541f5b 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/build.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/build.tcl @@ -1,5 +1,6 @@ #!/bin/sh # -*- tcl -*- \ -exec kettle -f "$0" "${1+$@}" -kettle tcl +# 'build.tcl' name as required by kettle +# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...`\ +exec ./kettle -f "$0" "${1+$@}" kettle doc diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index 1f0c0344..64b1794c 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -15,7 +15,7 @@ namespace eval ::punkmake { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project get-project-info] + variable known_commands [list project get-project-info shell bootsupport] } if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" @@ -134,6 +134,7 @@ foreach pkg $::punkmake::pkg_requirements { + proc punkmake_gethelp {args} { set scriptname [file tail [info script]] append h "Usage:" \n @@ -250,11 +251,22 @@ if {$::punkmake::command eq "get-project-info"} { } if {$::punkmake::command eq "shell"} { - #package require pu + package require punk + package require punk::repl + puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + repl::start stdin + + exit 1 +} +if {$::punkmake::command eq "bootsupport"} { + + + exit 1 } + if {$::punkmake::command ne "project"} { puts stderr "Command $::punkmake::command not implemented - aborting." exit 1 @@ -269,7 +281,11 @@ file mkdir $target_modules_base #external libs and modules first - and any supporting files - no 'building' required if {[file exists $sourcefolder/vendorlib]} { - #unpublish README.md from source folder - but on the root one + #unpublish README.md from source folder - but only the root one + #-unpublish_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) set unpublish [list\ README.md\ ] @@ -278,7 +294,8 @@ if {[file exists $sourcefolder/vendorlib]} { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" - puts stderr "Copied [llength $copied] vendor libs from src/vendorlib to $projectroot/lib" + flush stdout + puts stderr "Copied [llength $copied] vendor lib files from src/vendorlib to $projectroot/lib" foreach f $copied { puts stdout "COPIED $f" } @@ -295,7 +312,8 @@ if {[file exists $sourcefolder/vendormodules]} { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" - puts stderr "Copied [llength $copied] vendor modules from src/vendormodules to $target_modules_base" + flush stdout + puts stderr "Copied [llength $copied] vendor module files from src/vendormodules to $target_modules_base" foreach f $copied { puts stdout "COPIED $f" } @@ -305,6 +323,71 @@ if {[file exists $sourcefolder/vendormodules]} { puts stderr "NOTE: No src/vendormodules folder found." } +######################################################## +#templates +#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync +#src to src/modules/punk/mix/templates/layouts/project/src + +set layout_update_list [list\ + [list project $sourcefolder/modules/punk/mix/templates]\ + [list basic $sourcefolder/mixtemplates]\ + ] + +foreach layoutinfo $layout_update_list { + lassign $layoutinfo layout templatebase + if {![file exists $templatebase]} { + continue + } + set config [dict create\ + -make-step sync_templates\ + ] + #---------- + set tpl_installer [punkcheck::installtrack new make.tcl $templatebase/.punkcheck] + $tpl_installer set_source_target $sourcefolder $templatebase + set tpl_event [$tpl_installer start_event $config] + #---------- + set pairs [list] + set pairs [list\ + [list $sourcefolder/build.tcl $templatebase/layouts/$layout/src/build.tcl]\ + [list $sourcefolder/make.tcl $templatebase/layouts/$layout/src/make.tcl]\ + ] + + foreach filepair $pairs { + lassign $filepair srcfile tgtfile + #---------- + $tpl_event targetset_init INSTALL $tgtfile + $tpl_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$tpl_event targetset_source_changes] changed]]\ + || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ + } { + $tpl_event targetset_started + # -- --- --- --- --- --- + puts stdout "punk module templates: Copying from $srcfile to $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $tpl_event targetset_end FAILED -note "copy failed with err: $errM" + } else { + $tpl_event targetset_end OK -note "test" + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $tpl_event targetset_end SKIPPED + } + } + + $tpl_event end + $tpl_event destroy + $tpl_installer destroy +} +######################################################## + + + + #default source module folder is at projectroot/src/modules #There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] @@ -324,19 +407,15 @@ foreach src_module_dir $source_module_folderlist { set copied [dict get $resultdict files_copied] set sources_unchanged [dict get $resultdict sources_unchanged] puts stdout "--------------------------" + flush stdout puts stderr "Copied [llength $copied] non-tm source files from $src_module_dir to $target_modules_base" puts stderr "[llength $sources_unchanged] unchanged source files" + flush stderr puts stdout "--------------------------" } # ---------------------------------------- -set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] -if {![llength $vfs_folders]} { - puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" - puts stdout " -done- " - exit 0 -} set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] if {$buildfolder ne "$sourcefolder/_build"} { @@ -346,7 +425,7 @@ if {$buildfolder ne "$sourcefolder/_build"} { } -#find runtime - only supports one for now.. REVIEW +#find runtimes set rtfolder $sourcefolder/runtime set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] if {![llength $runtimes]} { @@ -360,51 +439,133 @@ if {[catch {exec sdx help} errM]} { exit 1 } - -if {[llength $runtimes] > 1} { - puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one." - exit 3 +# -- --- --- --- --- --- --- --- --- --- +#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. +#build a dict keyed on runtime executable name. +#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs +#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. +set mapfile $rtfolder/mapvfs.config +set runtime_vfs_map [dict create] +set vfs_runtime_map [dict create] +if {[file exists $mapfile]} { + set fdmap [open $mapfile r] + fconfigure $fdmap -translation binary + set mapdata [read $fdmap] + close $fdmap + set mapdata [string map [list \r\n \n] $mapdata] + set missing [list] + foreach ln [split $mapdata \n] { + set ln [string trim $ln] + if {$ln eq "" || [string match #* $ln]} { + continue + } + set vfspaths [lassign $ln runtime] + if {[string match *.exe $runtime]} { + #.exe is superfluous but allowed + #drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later + set runtime [string range $runtime 0 end-4] + } + set runtime_test $runtime + if {"windows" eq $::tcl_platform(platform)} { + set runtime_test $runtime.exe + } + if {![file exists [file join $rtfolder $runtime_test]]} { + puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" + lappend missing $runtime + } + foreach vfs $vfspaths { + if {![file isdirectory [file join $sourcefolder $vfs]]} { + puts stderr "WARNNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" + lappend missing $vfs + } + dict lappend vfs_runtime_map $vfs $runtime + } + if {[dict exists $runtime_vfs_map $runtime]} { + puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." + exit 3 + } + dict set runtime_vfs_map $runtime $vfspaths + } + if {[llength $missing]} { + puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" + foreach m $missing { + puts stderr " $m" + } + puts stderr "continuing..." + } } +# -- --- --- --- --- --- --- --- --- --- +set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] +#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) +foreach vfs [dict keys $vfs_runtime_map] { + if {$vfs ni $vfs_folders} { + lappend vfs_folders $vfs + } +} +if {![llength $vfs_folders]} { + puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" + puts stdout " -done- " + exit 0 +} +set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables set installername "make.tcl" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- -set runtimefile [lindex $runtimes 0] -#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh -#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) -#if {![file exists $buildfolder/buildruntime.exe]} { -# file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe -#} - -set basedir $buildfolder -set config [dict create\ - -make-step copy_runtime\ -] -lassign [punkcheck::start_installer_event $basedir/.punkcheck $installername $rtfolder $buildfolder $config] _eventid punkcheck_eventid _recordset record_list - - -set target_relpath [punkcheck::lib::path_relative $basedir $buildfolder/buildruntime.exe] -set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] -# -- --- --- --- --- --- -set source_relpath [punkcheck::lib::path_relative $basedir $rtfolder/$runtimefile] -set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] -# -- --- --- --- --- --- -set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] -if {[llength [dict get $changed_unchanged changed]]} { - set file_record [punkcheck::installfile_started_install $basedir $file_record] - # -- --- --- --- --- --- - puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/buildruntime.exe" - file copy -force $rtfolder/$runtimefile $buildfolder/buildruntime.exe - # -- --- --- --- --- --- - set file_record [punkcheck::installfile_finished_install $basedir $file_record] -} else { - puts stderr "." - set file_record [punkcheck::installfile_skipped_install $basedir $file_record] +#set runtimefile [lindex $runtimes 0] +foreach runtimefile $runtimes { + #runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms + + #sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh + #sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) + #if {![file exists $buildfolder/buildruntime.exe]} { + # file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe + #} + + set basedir $buildfolder + set config [dict create\ + -make-step copy_runtime\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] + $installer set_source_target $rtfolder $buildfolder + set event [$installer start_event $config] + $event targetset_init INSTALL $buildfolder/build_$runtimefile + $event targetset_addsource $rtfolder/$runtimefile + #---------- + + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" + if {[catch { + file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + } errM]} { + $event targetset_end FAILED + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $event targetset_end SKIPPED + } + $event end + } -# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- +# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- +# +# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. +# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. +# punkcheck allows us to not rely purely on timestamps (which may be unreliable) +# set startdir [pwd] puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." cd [file dirname $buildfolder] @@ -412,8 +573,9 @@ cd [file dirname $buildfolder] #a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. #Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. #Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. +set exe_names_seen [list] foreach vfs $vfs_folders { - + set vfsname [file rootname $vfs] puts stdout " Processing vfs $sourcefolder/$vfs" puts stdout " ------------------------------------" @@ -423,157 +585,213 @@ foreach vfs $vfs_folders { set config [dict create\ -make-step build_vfs\ ] - lassign [punkcheck::start_installer_event $basedir/.punkcheck $installername $sourcefolder $buildfolder $config] _eventid punkcheck_eventid _recordset record_list - - - set target_relpath [punkcheck::lib::path_relative $basedir $buildfolder/$vfsname.exe] - set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - # -- --- --- --- --- --- - set source_relpath [punkcheck::lib::path_relative $basedir $sourcefolder/$vfs] - set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - # -- --- --- --- --- --- - set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] - if {[llength [dict get $changed_unchanged changed]]} { - set file_record [punkcheck::installfile_started_install $basedir $file_record] - # -- --- --- --- --- --- - if {[file exists $buildfolder/$vfsname]} { - puts stderr "deleting existing $buildfolder/$vfsname" - file delete $sourcefolder/_build/$vfsname + set runtimes [list] + if {[dict exists $vfs_runtime_map $vfs]} { + set runtimes [dict get $vfs_runtime_map $vfs] ;#map dict is unsuffixed (.exe stripped or was not present) + if {"windows" eq $::tcl_platform(platform)} { + set runtimes_raw $runtimes + set runtimes [list] + foreach rt $runtimes_raw { + if {![string match *.exe $rt]} { + set rt $rt.exe + } + lappend runtimes $rt + } } + } else { + #only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime + set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project + if {![dict exists $runtime_vfs_map $matchrt]} { + if {"windows" eq $::tcl_platform(platform)} { + if {[file exists $rtfolder/$matchrt.exe]} { + lappend runtimes $matchrt.exe + } + } else { + lappend runtimes $matchrt + } + } + } + #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config - puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" + foreach rtname $runtimes { - if {[catch { - exec sdx wrap $buildfolder/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose - } result]} { - puts stderr "sdx wrap _build/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose failed with msg: $result" + #first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. + #review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. + if {$::tcl_platform(platform) eq "windows"} { + set targetexe ${vfsname}.exe } else { - puts stdout "ok - finished sdx" - set separator [string repeat = 40] - puts stdout $separator - puts stdout $result - puts stdout $separator + set targetexe $vfsname } - - if {![file exists $buildfolder/$vfsname]} { - puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" - exit 2 + if {$targetexe in $exe_names_seen} { + #more than one runtime for this .vfs + set targetexe ${vfsname}_$rtname } + lappend exe_names_seen $targetexe + # -- ---------- + set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] + $vfs_installer set_source_target $sourcefolder $buildfolder + set vfs_event [$vfs_installer start_event {-make-step build_vfs}] + $vfs_event targetset_init INSTALL $buildfolder/$targetexe + $vfs_event targetset_addsource $sourcefolder/$vfs + $vfs_event targetset_addsource $buildfolder/build_$rtname + # -- ---------- + + set changed_unchanged [$vfs_event targetset_source_changes] + + if {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]} { + #source .vfs folder has changes + $vfs_event targetset_started + # -- --- --- --- --- --- + + #use + if {[file exists $buildfolder/$vfsname.new]} { + puts stderr "deleting existing $buildfolder/$vfsname.new" + file delete $buildfolder/$vfsname.new + } + puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" + if {[catch { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose + } result]} { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" + } else { + puts stdout "ok - finished sdx" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } - # -- --- --- --- --- --- - set file_record [punkcheck::installfile_finished_install $basedir $file_record] - } else { - set skipped_vfs_build 1 - puts stderr "." - puts stdout "Skipping build for vfs $vfs - no change detected" - set file_record [punkcheck::installfile_skipped_install $basedir $file_record] - } - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - - - if {!$skipped_vfs_build} { - - if {$::tcl_platform(platform) eq "windows"} { - set pscmd "tasklist" - } else { - set pscmd "ps" - } + if {![file exists $buildfolder/$vfsname.new]} { + puts stderr "|err> make.tcl build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" + $vfs_event targetset_end FAILED + exit 2 + } - if {![catch { - exec $pscmd | grep $vfsname - } still_running]} { - puts stdout "found $vfsname instances still running\n" - set count_killed 0 - foreach ln [split $still_running \n] { - puts stdout " $ln" - - if {$::tcl_platform(platform) eq "windows"} { - set pid [lindex $ln 1] - if {$forcekill} { - set killcmd [list taskkill /F /PID $pid] + # -- --- --- + if {$::tcl_platform(platform) eq "windows"} { + set pscmd "tasklist" + } else { + set pscmd "ps" + } + + if {![catch { + exec $pscmd | grep $vfsname + } still_running]} { + + puts stdout "found $vfsname instances still running\n" + set count_killed 0 + foreach ln [split $still_running \n] { + puts stdout " $ln" + + if {$::tcl_platform(platform) eq "windows"} { + set pid [lindex $ln 1] + if {$forcekill} { + set killcmd [list taskkill /F /PID $pid] + } else { + set killcmd [list taskkill /PID $pid] + } } else { - set killcmd [list taskkill /PID $pid] + set pid [lindex $ln 0] + #review! + if {$forcekill} { + set killcmd [list kill -9 $pid] + } else { + set killcmd [list kill $pid] + } } - } else { - set pid [lindex $ln 0] - #review! - if {$forcekill} { - set killcmd [list kill -9 $pid] + puts stdout " pid: $pid (attempting to kill now using '$killcmd')" + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + puts stderr "(try '[info script] -k' option to force kill)" + exit 4 } else { - set killcmd [list kill $pid] + puts stderr "$killcmd ran without error" + incr count_killed } } - - puts stdout " pid: $pid (attempting to kill now using '$killcmd')" - + if {$count_killed > 0} { + puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" + after 1000 + } + } else { + puts stderr "Ok.. no running '$vfsname' processes found" + } + + if {[file exists $buildfolder/$targetexe]} { + puts stderr "deleting existing $buildfolder/$targetexe" if {[catch { - exec {*}$killcmd - } errMsg]} { - puts stderr "$killcmd returned an error:" - puts stderr $errMsg - puts stderr "(try '[info script] -k' option to force kill)" + file delete $buildfolder/$targetexe + } msg]} { + puts stderr "Failed to delete $buildfolder/$targetexe" exit 4 - } else { - puts stderr "$killcmd ran without error" - incr count_killed } } - if {$count_killed > 0} { - puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" - after 1000 + #WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetexe to copy ctime & shortname metadata from previous file! + #This is probably harmless - but worth being aware of. + file rename $buildfolder/$vfsname.new $buildfolder/$targetexe + # -- --- --- --- --- --- + $vfs_event targetset_end OK + + + after 200 + set deployment_folder [file dirname $sourcefolder]/bin + file mkdir $deployment_folder + + # -- ---------- + set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] + $bin_installer set_source_target $buildfolder $deployment_folder + set bin_event [$bin_installer start_event {-make-step final_exe_install}] + $bin_event targetset_init INSTALL $deployment_folder/$targetexe + $bin_event targetset_addsource $buildfolder/$targetexe + $bin_event targetset_started + # -- ---------- + + + set delete_failed 0 + if {[file exists $deployment_folder/$targetexe]} { + puts stderr "deleting existing deployed at $deployment_folder/$targetexe" + if {[catch { + file delete $deployment_folder/$targetexe + } errMsg]} { + puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" + #exit 5 + set delete_failed 1 + } } - } else { - puts stderr "Ok.. no running '$vfsname' processes found" - } - - if {$::tcl_platform(platform) eq "windows"} { - set targetexe ${vfsname}.exe - } else { - set targetexe $vfsname - } - - if {[file exists $buildfolder/$targetexe]} { - puts stderr "deleting existing $buildfolder/$targetexe" - if {[catch { - file delete $sourcefolder/_build/$targetexe - } msg]} { - puts stderr "Failed to delete $buildfolder/$targetexe" - exit 4 + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$buildfolder/$targetexe" + puts stdout "to:" + puts stdout "$deployment_folder/$targetexe" + after 300 + file copy $buildfolder/$targetexe $deployment_folder/$targetexe + # -- ---------- + $bin_event targetset_end OK + # -- ---------- + } else { + $bin_event targetset_end FAILED -note "could not delete } - } - - if {$::tcl_platform(platform) eq "windows"} { - file rename $buildfolder/$vfsname $sourcefolder/_build/${vfsname}.exe - } + $bin_event destroy + $bin_installer destroy - after 200 - set deployment_folder [file dirname $sourcefolder]/bin - file mkdir $deployment_folder - - if {[file exists $deployment_folder/$targetexe]} { - puts stderr "deleting existing deployed at $deployment_folder/$targetexe" - if {[catch { - file delete $deployment_folder/$targetexe - } errMsg]} { - puts stderr "deletion of deployed version at $deployment_folder/$targetexe failed: $errMsg" - exit 5 - } + } else { + set skipped_vfs_build 1 + puts stderr "." + puts stdout "Skipping build for vfs $vfs - no change detected" + $vfs_event targetset_end SKIPPED } - - - - puts stdout "copying.." - puts stdout "$buildfolder/$targetexe" - puts stdout "to:" - puts stdout "$deployment_folder/$targetexe" - after 500 - file copy $buildfolder/$targetexe $deployment_folder/$targetexe - } + $vfs_event destroy + $vfs_installer destroy + } ;#end foreach rtname in runtimes + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- } cd $startdir diff --git a/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/.gitignore b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/.gitignore new file mode 100644 index 00000000..4d6b6912 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/.gitignore @@ -0,0 +1,47 @@ + +/bin/ +/lib/ +#The directory for compiled/built Tcl modules +/modules/ +/vendorbuilds/ + +#Temporary files e.g from tests +/tmp/ + +/logs/ +**/_aside/ +**/_build/ +scratch* + +#Built documentation +/html/ +/man/ +/md/ +/doc/ + +/test* + + +#Built tclkits (if any) +punk*.exe +tcl*.exe + +#ignore fossil database files (but keep .fossil-settings and .fossil-custom in repository even if fossil not being used at your site) +_FOSSIL_ +.fos +.fslckout +*.fossil + +#miscellaneous editor files etc +*.swp + + +todo.txt + +zig-cache/ +zig-out/ +/release/ +/debug/ +/build/ +/build-*/ +/docgen_tmp/ diff --git a/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/README.md b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/README.md new file mode 100644 index 00000000..841c3dd3 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/README.md @@ -0,0 +1,13 @@ +%project% +============================== + ++ ++ + + +About +------------------------------ + ++ ++ ++ diff --git a/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/modules/README.md b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/modules/README.md new file mode 100644 index 00000000..1c037091 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/layouts/basic/src/modules/README.md @@ -0,0 +1,11 @@ +Tcl Module Source files for the project. +Consider using the punkshell pmix facility to create and manage these. + +pmix::newmodule will create a basic .tm module template and assist in versioning. + +Tcl modules can be namespaced. +For example +> pmix::newmodule mymodule::utils +will create the new module under src/modules/mymodule/utils + + diff --git a/src/modules/punk/mix/templates/module/template_module-0.0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/modules/template_module-0.0.1.tm similarity index 91% rename from src/modules/punk/mix/templates/module/template_module-0.0.1.tm rename to src/modules/punk/mix/templates/layouts/project/src/mixtemplates/modules/template_module-0.0.1.tm index 970f222c..65547b40 100644 --- a/src/modules/punk/mix/templates/module/template_module-0.0.1.tm +++ b/src/modules/punk/mix/templates/layouts/project/src/mixtemplates/modules/template_module-0.0.1.tm @@ -45,6 +45,7 @@ namespace eval %pkg% { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide %pkg% [namespace eval %pkg% { + variable pkg %pkg% variable version set version 999999.0a1.0 }] diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/pkgIndex.tcl b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/pkgIndex.tcl new file mode 100644 index 00000000..62ef2c5e --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/pkgIndex.tcl @@ -0,0 +1 @@ +package ifneeded app-sample 0.1 [list source [file join $dir sample.tcl]] diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/sample.tcl b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/sample.tcl new file mode 100644 index 00000000..45be7e4c --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sample/sample.tcl @@ -0,0 +1,8 @@ +namespace eval sample { + proc main {} { + puts stdout "[namespace current] argc $::argc argv $::argv" + puts stdout "[namespace current] done" + } + main +} +package provide app-sample 0.1 diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/pkgIndex.tcl b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/pkgIndex.tcl new file mode 100644 index 00000000..0bb9fda6 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/pkgIndex.tcl @@ -0,0 +1,2 @@ +package ifneeded app-sampleshell 0.1 [list source [file join $dir repl.tcl]] + diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/repl.tcl b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/repl.tcl new file mode 100644 index 00000000..ea63b453 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/lib/app-sampleshell/repl.tcl @@ -0,0 +1,111 @@ +package provide app-punk 1.0 + + +#punk linerepl launcher + + + +#------------------------------------------------------------------------------ +#Module loading +#------------------------------------------------------------------------------ +#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them +# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulpath if it's an ancestor of one of these.. + +set original_tm_list [tcl::tm::list] +tcl::tm::remove {*}$original_tm_list + +#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority +#1 +if {[file exists [pwd]/modules]} { + catch {tcl::tm::add [pwd]/modules} +} + +#2) +if {[string match "*.vfs/*" [info script]]} { + #src/xxx.vfs/lib/app-punk/repl.tcl + #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels + set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules + +} else { + # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) + set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules +} + +if {[file exists $modulefolder]} { + tcl::tm::add $modulefolder +} else { + puts stderr "Warning unable to find module folder at: $modulefolder" +} + +#libs are appended to end - so add higher prioriy libraries last (opposite to modules) +#auto_path - add exe-relative after exe-relative path +set libfolder [file dirname [file dirname [info nameofexecutable]]]/lib +if {[file exists $libfolder]} { + lappend ::auto_path $libfolder +} +if {[file exists [pwd]/lib]} { + lappend ::auto_path [pwd]/lib +} + + +#2) +#now add current dir (if no conflict with above) +set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] +set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] +if {[llength $currentdir_modules]} { + #only forget all *unloaded* package names if we are started in a .tm containing folder + foreach pkg [package names] { + if {$pkg in $tcl_core_packages} { + continue + } + if {![llength [package versions $pkg]]} { + #puts stderr "Got no versions for pkg $pkg" + continue + } + if {![string length [package provide $pkg]]} { + package forget $pkg + } + } + catch {tcl::tm::add [pwd]} +} + + +#puts stdout "$::auto_path" +package require Thread +#These are strong dependencies +# - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. +# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list +set required [list\ + shellfilter + shellrun\ + punk\ + ] + +catch { + foreach pkg $required { + package forget $pkg + package require $pkg + } +} + + +#restore module paths +set tm_list_now [tcl::tm::list] +foreach p $original_tm_list { + if {$p ni $tm_list_now} { + #the prior tm paths go to the head of the list. + #They are processed first.. but an item of same version later in the list will override one at the head. + tcl::tm::add $p + } +} +#------------------------------------------------------------------------------ + +foreach pkg $required { + package require $pkg +} + +package require punk::repl +repl::start stdin + + + diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/main.tcl b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/main.tcl new file mode 100644 index 00000000..04b77e5f --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/main.tcl @@ -0,0 +1,23 @@ + +if {[catch {package require starkit}]} { + #presumably running the xxx.vfs/main.tcl script using a non-starkit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway + lappend ::auto_path [file join [file dirname [info script]] lib] +} else { + starkit::startup +} + +#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it +set thisexe [file tail [info nameofexecutable]] +set thisexeroot [file rootname $thisexe] +set ::auto_execs($thisexeroot) [info nameofexecutable] +if {$thisexe ne $thisexeroot} { + set ::auto_execs($thisexe) [info nameofexecutable] +} + +if {[llength $::argv]} { + package require app-sample +} else { + package require app-sampleshell + repl::start stdin +} + diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellfilter-0.1.8.tm b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellfilter-0.1.8.tm new file mode 100644 index 00000000..53abd15c --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellfilter-0.1.8.tm @@ -0,0 +1,2862 @@ +#copyright 2023 Julian Marcel Noble +#license: BSD (revised 3-clause) +# +#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. +#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. +#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. +#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway +# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work +# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) +# + + +namespace eval shellfilter::log { + variable allow_adhoc_tags 0 + variable open_logs [dict create] + + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + package require shellthread + if {![dict exists $settingsdict -tag]} { + dict set settingsdict -tag $tag + } else { + if {$tag ne [dict get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[dict get $settingsdict -tag]' omit -tag, or supply same value" + } + } + if {$tag ni $sourcelist} { + lappend sourcelist $tag + } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid + } + proc write {tag msg} { + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + + #todo -implement + proc require_open {{is_open_required {}}} { + variable allow_adhoc_tags + if {![string length $is_open_required]} { + return $allow_adhoc_tags + } else { + set truevalues [list y yes true 1] + set falsevalues [list n no false 0] + if {[string tolower $is_open_required] in $truevalues} { + set allow_adhoc_tags 1 + } elseif {[string tolower $is_open_required] in $falsevalues} { + set allow_adhoc_tags 0 + } else { + error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" + } + } + } +} +namespace eval shellfilter::pipe { + #write channel for program. workerthread reads other end of fifo2 and writes data somewhere + proc open_out {tag_pipename {settingsdict {}}} { + package require shellthread + #we are only using the fifo in a single direction to pipe to another thread + # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each + if {![catch {package require Memchan}]} { + lassign [fifo2] wchan rchan + } else { + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + } + #default -translation for both types of fifo on windows is {auto crlf} + # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) + chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# + #application end must not be binary for our filters to operate on it + + + #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. + chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf + + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + #puts stderr "worker_tid: $worker_tid" + + #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer + shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan + + set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] + return $pipeinfo + } + + #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) + proc open_in {tag_pipename {settingsdict {} }} { + package require shellthread + package require tcl::chan::fifo2 + lassign [tcl::chan::fifo2] wchan rchan + set program_chan $rchan + set worker_chan $wchan + chan configure $worker_chan -buffering [dict get $settingsdict -buffering] + chan configure $program_chan -buffering [dict get $settingsdict -buffering] + + chan configure $program_chan -blocking 0 + chan configure $worker_chan -blocking 0 + set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] + + shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan + + set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] + puts stderr "|jn>pipe::open_in returning $pipeinfo" + puts stderr "program_chan: [chan conf $program_chan]" + return $pipeinfo + } + +} +namespace eval shellfilter::ansi2 { + #shellfilter::ansi procs only: adapted from ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control except where otherwise marked + variable test "blah\033\[1;33mETC\033\[0;mOK" + namespace export + = ? + #CSI m = SGR (Select Graphic Rendition) + variable SGR_setting_map { + bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 + underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 + reverse 7 noreverse 27 defaultfg 39 defaultbg 49 + overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 + } + variable SGR_colour_map { + black 30 red 31 green 32 yellow 33 blue 4 purple 35 cyan 36 white 37 + Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 + BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 + } + variable SGR_map + set SGR_map [dict merge $SGR_colour_map $SGR_setting_map] + + proc colourmap1 {{bgname White}} { + package require textblock + + set bg [textblock::block 3 33 "[a+ $bgname] [a=]"] + set colormap "" + for {set i 0} {$i <= 7} {incr i} { + append colormap "_[a+ white bold 48\;5\;$i] $i [a=]" + } + set map1 [overtype::left -transparent _ $bg "\n$colormap"] + return $map1 + } + proc colourmap2 {{bgname White}} { + package require textblock + set bg [textblock::block 3 39 "[a+ $bgname] [a=]"] + set colormap "" + for {set i 8} {$i <= 15} {incr i} { + append colormap "_[a+ black normal 48\;5\;$i] $i [a=]" ;#black normal is blacker than black bold - which often displays as a grey + } + set map2 [overtype::left -transparent _ $bg "\n$colormap"] + return $map2 + } + proc ? {args} { + variable SGR_setting_map + variable SGR_colour_map + + if {![llength $args]} { + set out "" + append out $SGR_setting_map \n + append out $SGR_colour_map \n + + try { + set bgname "White" + set map1 [colourmap1 $bgname] + set map1 [overtype::centre -transparent 1 $map1 "[a= black $bgname]Standard colours[a=]"] + set map2 [colourmap2 $bgname] + set map2 [overtype::centre -transparent 1 $map2 "[a= black $bgname]High-intensity colours[a=]"] + append out [textblock::join [textblock::join $map1 " "] $map2] \n + #append out $map1[a=] \n + #append out $map2[a=] \n + + + + } on error {result options} { + puts stderr "Failed to draw colormap" + puts stderr "$result" + } finally { + return $out + } + } else { + set result [list] + set rmap [lreverse $map] + foreach i $args { + if {[string is integer -strict $i]} { + if {[dict exists $rmap $i]} { + lappend result $i [dict get $rmap $i] + } + } else { + if {[dict exists $map $i]} { + lappend result $i [dict get $map $i] + } + } + } + return $result + } + } + proc + {args} { + #don't disable ansi here. + #we want this to be available to call even if ansi is off + variable SGR_map + set t [list] + foreach i $args { + if {[string is integer -strict $i]} { + lappend t $i + } elseif {[string first ";" $i] >=0} { + #literal with params + lappend t $i + } else { + if {[dict exists $SGR_map $i]} { + lappend t [dict get $SGR_map $i] + } else { + #accept examples for foreground + # 256f-# or 256fg-# or 256f# + # rgbf--- or rgbfg--- or rgbf-- + if {[string match -nocase "256f*" $i]} { + set cc [string trim [string range $i 4 end] -gG] + lappend t "38;5;$cc" + } elseif {[string match -nocase 256b* $i]} { + set cc [string trim [string range $i 4 end] -gG] + lappend t "48;5;$cc" + } elseif {[string match -nocase rgbf* $i]} { + set rgb [string trim [string range $i 4 end] -gG] + lassign [split $rgb -] r g b + lappend t "38;2;$r;$g;$b" + } elseif {[string match -nocase rgbb* $i]} { + set rgb [string trim [string range $i 4 end] -gG] + lassign [split $rgb -] r g b + lappend t "48;2;$r;$g;$b" + } + } + } + } + # \033 - octal. equivalently \x1b in hex which is more common in documentation + if {![llength $t]} { + return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) + } + return "\x1b\[[join $t {;}]m" + } + proc = {args} { + #don't disable ansi here. + #we want this to be available to call even if ansi is off + variable SGR_map + set t [list] + foreach i $args { + if {[string is integer -strict $i]} { + lappend t $i + } elseif {[string first ";" $i] >=0} { + #literal with params + lappend t $i + } else { + if {[dict exists $SGR_map $i]} { + lappend t [dict get $SGR_map $i] + } else { + #accept examples for foreground + # 256f-# or 256fg-# or 256f# + # rgbf--- or rgbfg--- or rgbf-- + if {[string match -nocase "256f*" $i]} { + set cc [string trim [string range $i 4 end] -gG] + lappend t "38;5;$cc" + } elseif {[string match -nocase 256b* $i]} { + set cc [string trim [string range $i 4 end] -gG] + lappend t "48;5;$cc" + } elseif {[string match -nocase rgbf* $i]} { + set rgb [string trim [string range $i 4 end] -gG] + lassign [split $rgb -] r g b + lappend t "38;2;$r;$g;$b" + } elseif {[string match -nocase rgbb* $i]} { + set rgb [string trim [string range $i 4 end] -gG] + lassign [split $rgb -] r g b + lappend t "48;2;$r;$g;$b" + } + } + } + } + # \033 - octal. equivalently \x1b in hex which is more common in documentation + # empty list [a=] should do reset - same for [a= nonexistant] + # explicit reset at beginning of parameter list for a= (as opposed to a+) + set t [linsert $t 0 0] + return "\x1b\[[join $t {;}]m" + } + + +} + + + +namespace eval shellfilter::ansi { + #maint warning - from overtype package + proc stripcodes {text} { + #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). + dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. + #line endings can theoretically occur within an ansi escape sequence (review e.g title?) + set inputlist [split $text ""] + set outputlist [list] + + #self-contained 2 byte ansi escape sequences - review more? + set 2bytecodes_dict [dict create\ + "reset_terminal" "\033c"\ + "save_cursor_posn" "\u001b7"\ + "restore_cursor_posn" "\u001b8"\ + "cursor_up_one" "\u001bM"\ + ] + set 2bytecodes [dict values $2bytecodes_dict] + + set in_escapesequence 0 + #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + set i 0 + foreach u $inputlist { + set v [lindex $inputlist $i+1] + set uv ${u}${v} + if {$in_escapesequence eq "2b"} { + #2nd byte - done. + set in_escapesequence 0 + } elseif {$in_escapesequence != 0} { + set escseq [dict get $escape_terminals $in_escapesequence] + if {$u in $escseq} { + set in_escapesequence 0 + } elseif {$uv in $escseq} { + set in_escapseequence 2b ;#flag next byte as last in sequence + } + } else { + #handle both 7-bit and 8-bit CSI and OSC + if {[regexp {^(?:\033\[|\u009b)} $uv]} { + set in_escapesequence CSI + } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { + set in_escapesequence OSC + } elseif {$uv in $2bytecodes} { + #self-contained e.g terminal reset - don't pass through. + set in_escapesequence 2b + } else { + lappend outputlist $u + } + } + incr i + } + return [join $outputlist ""] + } + +} +namespace eval shellfilter::chan { + set testobj ::shellfilter::chan::var + if {$testobj ni [info commands $testobj]} { + + oo::class create var { + variable o_datavar + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavar $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + append $o_datavar $stringdata + return "" + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line full none] + } + } + + #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? + oo::class create tee_grep_to_var { + variable o_datavar + variable o_lastxlines + variable o_trecord + variable o_grepfor + variable o_prelines + variable o_postlines + variable o_postcountdown + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set o_lastxlines [list] + set o_postcountdown 0 + set defaults [dict create -pre 1 -post 1] + set settingsdict [dict get $tf -settings] + set settings [dict merge $defaults $settingsdict] + set o_datavar [dict get $settings -varname] + set o_grepfor [dict get $settings -grep] + set o_prelines [dict get $settings -pre] + set o_postlines [dict get $settings -post] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + set lastx $o_lastxlines + lappend o_lastxlines $logdata + + if {$o_postcountdown > 0} { + append $o_datavar $logdata + if {[regexp $o_grepfor $logdata]} { + #another match in postlines + set o_postcountdown $o_postlines + } else { + incr o_postcountdown -1 + } + } else { + if {[regexp $o_grepfor $logdata]} { + append $o_datavar [join $lastx] + append $o_datavar $logdata + set o_postcountdown $o_postlines + } + } + + if {[llength $o_lastxlines] > $o_prelines} { + set o_lastxlines [lrange $o_lastxlines 1 end] + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + method meta_buffering_supported {} { + return [list line] + } + } + + oo::class create tee_to_var { + variable o_datavars + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + set varname [dict get $settingsdict -varname] + set o_datavars $varname + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize finalize write] + } + method finalize {ch} { + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {ch count} { + # return ? + #} + method write {ch bytes} { + set stringdata [encoding convertfrom $o_enc $bytes] + foreach v $o_datavars { + append $v $stringdata + } + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + oo::class create tee_to_pipe { + variable o_logsource + variable o_localchan + variable o_enc + variable o_trecord + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_pipe constructor settingsdict missing -tag" + } + set o_localchan [dict get $settingsdict -pipechan] + set o_logsource [dict get $settingsdict -tag] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + method read {transform_handle bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + method write {transform_handle bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + #::shellfilter::log::write $o_logsource $logdata + puts -nonewline $o_localchan $logdata + return $bytes + } + #a tee is not a redirection - because data still flows along the main path + method meta_is_redirection {} { + return $o_is_junction + } + + } + oo::class create tee_to_log { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "tee_to_log constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {ch mode} { + return [list initialize read write finalize] + } + method finalize {ch} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {ch events} { + # must be present but we ignore it because we do not + # post any events + } + method read {ch bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method write {ch bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + ::shellfilter::log::write $o_logsource $logdata + return $bytes + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + + oo::class create logonly { + variable o_tid + variable o_logsource + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {![dict exists $settingsdict -tag]} { + error "logonly constructor settingsdict missing -tag" + } + set o_logsource [dict get $settingsdict -tag] + set o_tid [::shellfilter::log::open $o_logsource $settingsdict] + } + method initialize {transform_handle mode} { + return [list initialize finalize write] + } + method finalize {transform_handle} { + ::shellfilter::log::close $o_logsource + my destroy + } + method watch {transform_handle events} { + # must be present but we ignore it because we do not + # post any events + } + #method read {transform_handle count} { + # return ? + #} + method write {transform_handle bytes} { + set logdata [encoding convertfrom $o_enc $bytes] + if 0 { + if {"utf-16le" in [encoding names]} { + set logdata [encoding convertfrom utf-16le $bytes] + } else { + set logdata [encoding convertto utf-8 $bytes] + #set logdata [encoding convertfrom unicode $bytes] + #set logdata $bytes + } + } + #set logdata $bytes + #set logdata [string map [list \r -r- \n -n-] $logdata] + #if {[string equal [string range $logdata end-1 end] "\r\n"]} { + # set logdata [string range $logdata 0 end-2] + #} + #::shellfilter::log::write_sync $o_logsource $logdata + ::shellfilter::log::write $o_logsource $logdata + #return $bytes + return + } + method meta_is_redirection {} { + return 1 + } + } + + #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) + # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) + #punk::ansi::stripansi converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #assumes line-buffering. a more advanced filter required if ansicodes can arrive split accross separate read or write operations! + oo::class create ansistrip { + variable o_trecord + variable o_enc + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [dict get $tf -encoding] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::stripansi $instring] + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring [punk::ansi::stripansi $instring] + return [encoding convertto $o_enc $outstring] + #return [encoding convertto unicode $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + + #a test + oo::class create reconvert { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + } + oo::define reconvert { + method meta_is_redirection {} { + return 0 + } + } + + oo::class create ansiwrap { + variable o_trecord + variable o_enc + variable o_colour + variable o_do_colour + variable o_do_normal + variable o_is_junction + constructor {tf} { + package require punk::ansi + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $settingsdict -colour]} { + set o_colour [dict get $settingsdict -colour] + set o_do_colour [punk::ansi::a+ {*}$o_colour] + set o_do_normal [punk::ansi::a] + } else { + set o_colour {} + set o_do_colour "" + set o_do_normal "" + } + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + set outstring "$o_do_colour$instring$o_do_normal" + #set outstring ">>>$instring" + return [encoding convertto $o_enc $outstring] + } + method meta_is_redirection {} { + return $o_is_junction + } + } + #todo - something + oo::class create rebuffer { + variable o_trecord + variable o_enc + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + } + method initialize {transform_handle mode} { + return [list initialize read write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + #set outstring [string map [list \n ] $instring] + set outstring $instring + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define rebuffer { + method meta_is_redirection {} { + return 0 + } + } + + #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence + oo::class create tounix { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map [list \r\n \n] $instring] + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define tounix { + method meta_is_redirection {} { + return $o_is_junction + } + } + #write to handle case where line-endings already \r\n too + oo::class create towindows { + variable o_trecord + variable o_enc + variable o_last_char_was_cr + variable o_is_junction + constructor {tf} { + set o_trecord $tf + set o_enc [dict get $tf -encoding] + set settingsdict [dict get $tf -settings] + if {[dict exists $tf -junction]} { + set o_is_junction [dict get $tf -junction] + } else { + set o_is_junction 0 + } + set o_last_char_was_cr 0 + } + method initialize {transform_handle mode} { + return [list initialize write finalize] + } + method finalize {transform_handle} { + my destroy + } + method watch {transform_handle events} { + } + #don't use read + method read {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + + set outstring $instring + + return [encoding convertto $o_enc $outstring] + } + method write {transform_handle bytes} { + set instring [encoding convertfrom $o_enc $bytes] + #set outstring [string map [list \n ] $instring] + + if {$o_last_char_was_cr} { + set instring "\r$instring" + } + + set outstring [string map [list \r\n \uFFFF] $instring] + set outstring [string map [list \n \r\n] $outstring] + set outstring [string map [list \uFFFF \r\n] $outstring] + + set lastchar [string range $outstring end end] + if {$lastchar eq "\r"} { + set o_last_char_was_cr 1 + set outstring [string range $outstring 0 end-1] + } else { + set o_last_char_was_cr 0 + } + #review! can we detect eof here on the transform_handle? + #if eof, we don't want to strip a trailing \r + + return [encoding convertto $o_enc $outstring] + #return [encoding convertto utf-16le $outstring] + } + } + oo::define towindows { + method meta_is_redirection {} { + return $o_is_junction + } + } + + } +} + +# ---------------------------------------------------------------------------- +#review float/sink metaphor. +#perhaps something with the concept of upstream and downstream? +#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. +## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. +#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) +#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. +#The idea would be that whether input or output +# upstream additions go to the side closest to the datasource +# downstream additions go furthest from the datasource +# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. +# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. +# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) +# neutral-upstream goes to the datasource side of the neutral-upstream list. +# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. +# No 'neutral-downstream' to reduce complexity. +# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. +# +# ---------------------------------------------------------------------------- +# +# 'filters' are transforms that don't redirect +# - limited range of actions to reduce complexity. +# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes +# +#actions can float to top of filters or sink to bottom of filters +#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) +# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack +# +##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, +#but non-floats added later will sit below all floats. +#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) +# +# +#action: float sink sink-replace,sink-sideline +# +# +## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. +## +namespace eval shellfilter::stack { + #todo - implement as oo + variable pipelines [list] + + proc items {} { + #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. + # - but in what contexts? only when we find them in [chan names]? + variable pipelines + return [dict keys $pipelines] + } + + proc status {{pipename *} args} { + variable pipelines + + set pipecount [dict size $pipelines] + set tableprefix "$pipecount pipelines active\n" + package require overtype + #todo -verbose + set table "" + set ac1 [string repeat " " 15] + set ac2 [string repeat " " 32] + set ac3 [string repeat " " 80] + append table "[overtype::left $ac1 channel-ident] " + append table "[overtype::left $ac2 device-info] " + append table "[overtype::left $ac3 stack-info]" + append table \n + + + set bc1 [string repeat " " 5] ;#stack id + set bc2 [string repeat " " 25] ;#transform + set bc3 [string repeat " " 50] ;#settings + + foreach k [dict keys $pipelines $pipename] { + set lc [dict get $pipelines $k device localchan] + + + set col1 [overtype::left $ac1 $k] + set col2 [overtype::left $ac2 "localchan: $lc"] + + set stack [dict get $pipelines $k stack] + if {![llength $stack]} { + set col3 $ac3 + } else { + set rec [lindex $stack 0] + set bcol1 [overtype::left $bc1 [dict get $rec -id]] + set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bcol3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bcol1 $bcol2 $bcol3" + set col3 [overtype::left $ac3 $stackrow] + } + + append table "$col1 $col2 $col3\n" + + + foreach rec [lrange $stack 1 end] { + set col1 $ac1 + set col2 $ac2 + if {[llength $rec]} { + set bc1 [overtype::left $bc1 [dict get $rec -id]] + set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] + set bc3 [overtype::left $bc3 [dict get $rec -settings]] + set stackrow "$bc1 $bc2 $bc3" + set col3 [overtype::left $ac3 $stackrow] + } else { + set col3 $ac3 + } + append table "$col1 $col2 $col3\n" + } + + } + return $tableprefix$table + } + #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir + proc _get_stack_floaters {stack} { + set floaters [list] + foreach t [lreverse $stack] { + if {[dict get $t -action] eq "float"} { + lappend floaters $t + } else { + break + } + } + return [lreverse $floaters] + } + + + + #for output-channel sinking + proc _get_stack_top_redirection {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + incr r + } + #not found + return [list index -1 record {}] + } + #exclude float-locked, locked, sink-locked + proc _get_stack_top_redirection_replaceable {stack} { + set r 0 ;#reverse index + foreach t [lreverse $stack] { + set action [dict get $t -action] + if {![string match "*locked*" $action]} { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index + return [list index $idx record $t] + } + } + incr r + } + #not found + return [list index -1 record {}] + } + + + #for input-channels ? + proc _get_stack_bottom_redirection {stack} { + set i 0 + foreach t $stack { + set obj [dict get $t -obj] + if {[$obj meta_is_redirection]} { + return [linst index $i record $t] + } + incr i + } + #not found + return [list index -1 record {}] + } + + + proc get_next_counter {pipename} { + variable pipelines + #use dictn incr ? + set counter [dict get $pipelines $pipename counter] + incr counter + dict set pipelines $pipename counter $counter + return $counter + } + + proc unwind {pipename} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + foreach tf [lreverse $stack] { + chan pop $localchan + } + dict set pipelines $pipename [list] + } + #todo + proc delete {pipename} { + set pipeinfo [dict get $pipename] + set deviceinfo [dict get $pipeinfo device] + set localchan [dict get $deviceinfo localchan] + unwind $pipename + + + chan close $localchan + } + proc remove {pipename remove_id} { + variable pipelines + if {![dict exists $pipelines $pipename]} { + puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" + return + } + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $pipelines $pipename device localchan] + set posn 0 + set idposn -1 + set asideposn -1 + foreach t $stack { + set id [dict get $t -id] + if {$id eq $remove_id} { + set idposn $posn + break + } + #look into asides (only can be one for now) + if {[llength [dict get $t -aside]]} { + set a [dict get $t -aside] + if {[dict get $a -id] eq $remove_id} { + set asideposn $posn + break + } + } + incr posn + } + + if {$asideposn > 0} { + #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record + set container [lindex $stack $asideposn] + dict set container -aside {} + lset stack $asideposn $container + dict set pipelines $pipename stack $stack + } else { + if {$idposn < 0} { + ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" + puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" + return 0 + } + set removed_item [lindex $stack $idposn] + + #include idposn in poplist + set poplist [lrange $stack $idposn end] + set stack [lreplace $stack $idposn end] + #pop all chans before adding anything back in! + foreach p $poplist { + chan pop $localchan + } + + if {[llength [dict get $removed_item -aside]]} { + set restore [dict get $removed_item -aside] + set t [dict get $restore -transform] + set tsettings [dict get $restore -settings] + set obj [$t new $restore] + set h [chan push $localchan $obj] + dict set restore -handle $h + dict set restore -obj $obj + lappend stack $restore + } + + #put popped back except for the first one, which we want to remove + foreach p [lrange $poplist 1 end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + dict set p -handle $h + dict set p -obj $obj + lappend stack $p + } + dict set pipelines $pipename stack $stack + } + show_pipeline $pipename -note "after_remove $remove_id" + + return 1 + } + + #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) + proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { + variable pipelines + set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] + set poplist [lrange $stack $bottom_pop_posn end] + set stack [lreplace $stack $bottom_pop_posn end] + + set localchan [dict get $pipelines $pipename device localchan] + foreach p [lreverse $poplist] { + chan pop $localchan + } + set transformname [dict get $transformrecord -transform] + set transformsettings [dict get $transformrecord -settings] + set obj [$transformname new $transformrecord] + set h [chan push $localchan $obj] + dict set transformrecord -handle $h + dict set transformrecord -obj $obj + dict set transformrecord -note "insert_transform" + lappend stack $transformrecord + foreach p [lrange $poplist $pushstartindex end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added" + + lappend stack $p + } + return $stack + } + + #fifo2 + proc new {pipename args} { + variable pipelines + if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { + error "shellfilter::stack::new error: pipename '$pipename' already exists" + } + + set opts [dict merge {-settings {}} $args] + set defaultsettings [dict create -raw 1 -buffering line -direction out] + set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] + + set direction [dict get $targetsettings -direction] + + #pipename is the source/facility-name ? + if {$direction eq "out"} { + set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] + } else { + puts stderr "|jn> pipe::open_in $pipename $targetsettings" + set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] + } + #open_out/open_in will configure buffering based on targetsettings + + set program_chan [dict get $pipeinfo localchan] + set worker_chan [dict get $pipeinfo remotechan] + set workertid [dict get $pipeinfo workertid] + + + set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + + return $deviceinfo + } + #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack + proc add {pipename transformname args} { + variable pipelines + if {($pipename ni [chan names]) && ($pipename ni [dict keys $pipelines])} { + error "shellfilter::stack::add no existing chan or pipename matching '$pipename' use stdin/stderr/stdout or shellfilter::stack::new " + } + set args [dict merge {-action "" -settings {}} $args] + set action [dict get $args -action] + set transformsettings [dict get $args -settings] + if {[string first "::" $transformname] < 0} { + set transformname ::shellfilter::chan::$transformname + } + if {![llength [info commands $transformname]]} { + error "shellfilter::stack::push unknown transform '$transformname'" + } + + + if {![dict exists $pipelines $pipename]} { + #pipename must be in chan names - existing device/chan + #record a -read and -write end even if the device is only being used as one or the other + set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] + dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] + } else { + set deviceinfo [dict get $pipelines $pipename device] + } + + set id [get_next_counter $pipename] + set stack [dict get $pipelines $pipename stack] + set localchan [dict get $deviceinfo localchan] + + #we redundantly store chan in each transform - makes debugging clearer + # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), + # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) + # jn + set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] + + if {$action in [list "float" "float-locked"]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } elseif {$action in [list "locked" ""]} { + set floaters [_get_stack_floaters $stack] + if {![llength $floaters]} { + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + lappend stack $transform_record + } else { + set poplist $floaters + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } elseif {[string match sink* $action]} { + set redirinfo [_get_stack_top_redirection $stack] + set idx_existing_redir [dict get $redirinfo index] + if {$idx_existing_redir == -1} { + #no existing redirection transform on the stack + #pop everything.. add this record as the first redirection on the stack + set poplist $stack + set stack [insert_transform $pipename $stack $transform_record $poplist] + } else { + if {$action eq "sink-replace"} { + #include that index in the poplist + set poplist [lrange $stack $idx_existing_redir end] + #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' + set stack [insert_transform $pipename $stack $transform_record $poplist 1] + } elseif {[string match "sink-aside*" $action]} { + set existing_redir_record [lindex $stack $idx_existing_redir] + if {[string match "*locked*" [dict get $existing_redir_record -action]]} { + set put_aside 0 + #we can't aside this one - sit above it instead. + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [lrange $stack 0 $idx_existing_redir] + } else { + set put_aside 1 + dict set transform_record -aside [lindex $stack $idx_existing_redir] + set poplist [lrange $stack $idx_existing_redir end] + set stack [lrange $stack 0 $idx_existing_redir-1] + } + foreach p $poplist { + chan pop $localchan + } + set transformname [dict get $transform_record -transform] + set transform_settings [dict get $transform_record -settings] + set obj [$transformname new $transform_record] + set h [chan push $localchan $obj] + dict set transform_record -handle $h + dict set transform_record -obj $obj + dict set transform_record -note "insert_transform-with-aside" + lappend stack $transform_record + #add back poplist *except* the one we transferred into -aside (if we were able) + foreach p [lrange $poplist $put_aside end] { + set t [dict get $p -transform] + set tsettings [dict get $p -settings] + set obj [$t new $p] + set h [chan push $localchan $obj] + #retain previous -id - code that added it may have kept reference and not expecting it to change + dict set p -handle $h + dict set p -obj $obj + dict set p -note "re-added-after-sink-aside" + lappend stack $p + } + } else { + #plain "sink" + #we only sink to the topmost redirecting filter - which makes sense for an output channel + #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. + #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. + # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. + # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour + set poplist [lrange $stack $idx_existing_redir+1 end] + set stack [insert_transform $pipename $stack $transform_record $poplist] + } + } + } else { + error "shellfilter::stack::add unimplemented action '$action'" + } + + dict set pipelines $pipename stack $stack + #puts stdout "==" + #puts stdout "==>stack: $stack" + #puts stdout "==" + show_pipeline $pipename -note "after_add $transformname $args" + return $id + } + proc show_pipeline {pipename args} { + variable pipelines + set stack [dict get $pipelines $pipename stack] + set tag "SHELLFILTER::STACK" + #JMN - load from config + #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} + ::shellfilter::log::open $tag {-syslog ""} + ::shellfilter::log::write $tag "transform stack for $pipename $args" + foreach tf $stack { + ::shellfilter::log::write $tag " $tf" + } + + } +} + + +namespace eval shellfilter { + variable sources [list] + variable stacks [dict create] + + proc ::shellfilter::redir_channel_to_log {chan args} { + variable sources + set default_logsettings [dict create \ + -tag redirected_$chan -syslog "" -file ""\ + ] + if {[dict exists $args -action]} { + set action [dict get $args -action] + } else { + # action "sink" is a somewhat reasonable default for an output redirection transform + # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack + # also.. for stdin transform sink makes less sense.. + #todo - default "stack" instead of empty string + set action "" + } + if {[dict exists $args -settings]} { + set logsettings [dict get $args -settings] + } else { + set logsettings {} + } + + set logsettings [dict merge $default_logsettings $logsettings] + set tag [dict get $logsettings -tag] + if {$tag ni $sources} { + lappend sources $tag + } + + set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] + return $id + } + + proc ::shellfilter::redir_output_to_log {tagprefix args} { + variable sources + + set default_settings [list -tag ${tagprefix} -syslog "" -file ""] + + set opts [dict create -action "" -settings {}] + set opts [dict merge $opts $args] + set optsettings [dict get $opts -settings] + set settings [dict merge $default_settings $optsettings] + + set tag [dict get $settings -tag] + if {$tag ne $tagprefix} { + error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" + } + lappend sources ${tagprefix}stdout ${tagprefix}stderr + + set stdoutsettings $settings + dict set stdoutsettings -tag ${tagprefix}stdout + set stderrsettings $settings + dict set stderrsettings -tag ${tagprefix}stderr + + set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] + set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] + + return [list $idout $iderr] + } + + #return a dict keyed on numerical list index showing info about each element + # - particularly + # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list + # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) + proc list_element_info {inputlist} { + set i 0 + set info [dict create] + set testlist [list] + foreach original_item $inputlist { + #--- + # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) + unset -nocomplain item + append item $original_item {} + #--- + + set iteminfo [dict create] + set itemlen [string length $item] + lappend testlist $item + set tcl_len [string length $testlist] + set diff [expr {$tcl_len - $itemlen}] + if {$diff == 0} { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 0 + } else { + #test for escaping vs bracing! + set testlistchars [split $testlist ""] + if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { + dict set iteminfo wouldbrace 1 + dict set iteminfo wouldescape 0 + } else { + dict set iteminfo wouldbrace 0 + dict set iteminfo wouldescape 1 + } + } + set testlist [list] + set charlist [split $item ""] + set char_a [lindex $charlist 0] + set char_b [lindex $charlist 1] + set char_ab ${char_a}${char_b} + set char_y [lindex $charlist end-1] + set char_z [lindex $charlist end] + set char_yz ${char_y}${char_z} + + if { ("{" in $charlist) || ("}" in $charlist) } { + dict set iteminfo has_braces 1 + set innerchars [lrange $charlist 1 end-1] + if {("{" in $innerchars) || ("}" in $innerchars)} { + dict set iteminfo has_inner_braces 1 + } else { + dict set iteminfo has_inner_braces 0 + } + } else { + dict set iteminfo has_braces 0 + dict set iteminfo has_inner_braces 0 + } + + #todo - brace/char counting to determine if actually 'wrapped' + #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. + #also {(x) (y)} as a list member.. how to treat? + if {$itemlen <= 1} { + dict set iteminfo apparentwrap "not" + } else { + if {($char_a eq {"}) && ($char_z eq {"})} { + dict set iteminfo apparentwrap "doublequotes" + } elseif {($char_a eq "'") && ($char_z eq "'")} { + dict set iteminfo apparentwrap "singlequotes" + } elseif {($char_a eq "(") && ($char_z eq ")")} { + dict set iteminfo apparentwrap "brackets" + } elseif {($char_a eq "\{") && ($char_z eq "\}")} { + dict set iteminfo apparentwrap "braces" + } elseif {($char_a eq "^") && ($char_z eq "^")} { + dict set iteminfo apparentwrap "carets" + } elseif {($char_a eq "\[") && ($char_z eq "\]")} { + dict set iteminfo apparentwrap "squarebrackets" + } elseif {($char_a eq "`") && ($char_z eq "`")} { + dict set iteminfo apparentwrap "backquotes" + } elseif {($char_a eq "\n") && ($char_z eq "\n")} { + dict set iteminfo apparentwrap "lf-newline" + } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { + dict set iteminfo apparentwrap "crlf-newline" + } else { + dict set iteminfo apparentwrap "not-determined" + } + + } + dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. + #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 + dict set iteminfo head_tail_chars [list $char_a $char_z] + set namemap [list \ + \r cr\ + \n lf\ + {"} doublequote\ + {'} singlequote\ + "`" backquote\ + "^" caret\ + \t tab\ + " " sp\ + "\[" lsquare\ + "\]" rsquare\ + "(" lbracket\ + ")" rbracket\ + "\{" lbrace\ + "\}" rbrace\ + \\ backslash\ + / forwardslash\ + ] + if {[string length $char_a]} { + set char_a_name [string map $namemap $char_a] + } else { + set char_a_name "emptystring" + } + if {[string length $char_z]} { + set char_z_name [string map $namemap $char_z] + } else { + set char_z_name "emptystring" + } + + dict set iteminfo head_tail_names [list $char_a_name $char_z_name] + dict set iteminfo len $itemlen + dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. + dict set info $i $iteminfo + incr i + } + return $info + } + + + #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list + #e.g {(^c:/my spacey/path^ >^somewhere^)} + #e.g {(blah (etc))}" + #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} + # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc + # Note that + #maintenance warning - duplication in branches for bracketed vs unbracketed! + proc parse_cmd_brackets {str} { + #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. + # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space + # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. + set wordwrappers [list \ + "\"" [list "\"" "\"" "\""]\ + {^} [list "\"" "\"" "^"]\ + "'" [list "'" "'" "'"]\ + "\{" [list "\{" "\}" "\}"]\ + {[} [list {[} {]} {]}]\ + ] ;#dict mapping start_character to {replacehead replacetail expectedtail} + set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. + #puts "pb:$str" + set in_bracket 0 + set in_word 0 + set word "" + set result {} + set word_bdepth 0 + set word_bstack [list] + set wordwrap "" ;#only one active at a time + set bracketed_elements [dict create] + foreach char [split $str ""] { + #puts "c:$char bracketed:$bracketed_elements" + if {$in_bracket > 0} { + if {$in_word} { + if {[string length $wordwrap]} { + #anything goes until end-char + #todo - lookahead and only treat as closing if before a space or ")" ? + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + if {$word_bdepth == 0} { + #can potentially close off a word - or start a new one if word-so-far is a shell-special + if {$word in $shell_specials} { + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + } else { + + if {$char eq ")"} { + dict lappend bracketed_elements $in_bracket $word + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + set word "" + set in_word 0 + } elseif {[regexp {[\s]} $char]} { + dict lappend bracketed_elements $in_bracket $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + #ordinary word up-against and opening bracket - brackets are part of word. + incr word_bdepth + append word "(" + } else { + append word $char + } + } + } else { + #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. + if {$char eq "("} { + incr word_bdepth + lappend word_bstack $char + append word $char + } elseif {$char eq ")"} { + incr word_bdepth -1 + set word_bstack [lrange $word_bstack 0 end-1] + append word $char + } else { + #spaces and chars added to word as it's still in a bracketed section + append word $char + } + } + } + } else { + + if {$char eq "("} { + incr in_bracket + + } elseif {$char eq ")"} { + set subresult [dict get $bracketed_elements $in_bracket] + dict set bracketed_elements $in_bracket [list] + incr in_bracket -1 + if {$in_bracket == 0} { + lappend result $subresult + } else { + dict lappend bracketed_elements $in_bracket $subresult + } + } elseif {[regexp {[\s]} $char]} { + # + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } else { + if {$in_word} { + if {[string length $wordwrap]} { + lassign [dict get $wordwrappers $wordwrap] _open closing endmark + if {$char eq $endmark} { + set wordwrap "" + append word $closing + lappend result $word + set word "" + set in_word 0 + } else { + append word $char + } + } else { + + if {$word_bdepth == 0} { + if {$word in $shell_specials} { + if {[regexp {[\s]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + lappend result $word + set word "" + set in_word 0 + incr in_bracket + } else { + #at end of shell-specials is another point to look for word started by a wordwrapper char + #- expect common case of things like >^/my/path^ + if {$char in [dict keys $wordwrappers]} { + lappend result $word + set word "" + set in_word 1 ;#just for explicitness.. we're straight into the next word. + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + #something unusual.. keep going with word! + append word $char + } + } + + } else { + if {[regexp {[\s)]} $char]} { + lappend result $word + set word "" + set in_word 0 + } elseif {$char eq "("} { + incr word_bdepth + append word $char + } else { + append word $char + } + } + } else { + if {$char eq "("} { + incr word_bdepth + append word $char + } elseif {$char eq ")"} { + incr word_bdepth -1 + append word $char + } else { + append word $char + } + } + } + } else { + if {[regexp {[\s]} $char]} { + #insig whitespace(?) + } elseif {$char eq "("} { + incr in_bracket + dict set bracketed_elements $in_bracket [list] + } elseif {$char eq ")"} { + error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" + } else { + #first char of word - look for word-wrappers + if {$char in [dict keys $wordwrappers]} { + set wordwrap $char + set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. + } else { + set word $char + } + set in_word 1 + } + } + } + #puts "----$bracketed_elements" + } + if {$in_bracket > 0} { + error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" + } + if {[dict exists $bracketed_elements 0]} { + #lappend result [lindex [dict get $bracketed_elements 0] 0] + lappend result [dict get $bracketed_elements 0] + } + if {$in_word} { + lappend result $word + } + return $result + } + + #only double quote if argument not quoted with single or double quotes + proc dquote_if_not_quoted {a} { + if {([string range $a 0 0] eq {"}) && ([string range $a end end] eq {"})} { + return $a + } elseif {([string range $a 0 0] eq {'}) && ([string range $a end end] eq {'})} { + return $a + } else { + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + + #proc dquote_if_not_bracketed/braced? + + #wrap in double quotes if not double-quoted + proc dquote_if_not_dquoted {a} { + if {([string range $a 0 0] eq {"}) && ([string range $a end end] eq {"})} { + return $a + } else { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + } + proc dquote {a} { + #escape any inner quotes.. + set newinner [string map [list {"} "\\\""] $a] + return "\"$newinner\"" + } + proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { + set scr [auto_execok "script"] + if {[string length $scr]} { + #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" + set arg1 [lindex $cmdlist 0] + if {[string first " " $arg1]>0} { + set c1 [dquote_if_not_quoted $arg1] + #set c1 "\"$arg1\"" + } else { + set c1 $arg1 + } + + if {[string length $shellcmdflag]} { + set scriptrun "$shellcmdflag \$($c1 " + } else { + set scriptrun "\$($c1 " + } + #set scriptrun "$c1 " + foreach a [lrange $cmdlist 1 end] { + #set a [string map [list "/" "//"] $a] + #set a [string map [list "\"" "\\\""] $a] + if {[string first " " $a] > 0} { + append scriptrun [dquote_if_not_quoted $a] + } else { + append scriptrun $a + } + append scriptrun " " + } + set scriptrun [string trim $scriptrun] + append scriptrun ")" + #return [list $scr -q -e -c $scriptrun /dev/null] + return [list $scr -e -c $scriptrun /dev/null] + } else { + return $cmdlist + } + } + + proc ::shellfilter::trun {commandlist args} { + #jmn + } + + + # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) + # By the point run is called - any transforms should already be in place on the channels if they're needed. + # The tees will be inline with none,some or all of those transforms depending on how the stack was configured + # (upstream,downstream configured via -float,-sink etc) + proc ::shellfilter::run {commandlist args} { + #must be a list. If it was a shell commandline string. convert it elsewhere first. + + variable sources + set runtag "shellfilter-run" + #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + ::shellfilter::log::write $runtag " commandlist:'$commandlist' len:[llength $commandlist]" + + #flush stdout + #flush stderr + + #adding filters with sink-aside will temporarily disable the existing redirection + #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog + + set defaults [dict create \ + -teehandle command \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -tclscript 0 \ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set outchan [dict get $opts -outchan] + set errchan [dict get $opts -errchan] + set inchan [dict get $opts -inchan] + set teehandle [dict get $opts -teehandle] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set is_script [dict get $opts -tclscript] + dict unset opts -tclscript ;#don't pass it any further + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set teehandle_out ${teehandle}out ;#default commandout + set teehandle_err ${teehandle}err + set teehandle_in ${teehandle}in + + + #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" + + # sources should be added when stack::new called instead(?) + foreach source [list $teehandle_out $teehandle_err] { + if {$source ni $sources} { + lappend sources $source + } + } + set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] + set outpipechan [dict get $outdeviceinfo localchan] + set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] + set errpipechan [dict get $errdeviceinfo localchan] + + #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] + #set inpipechan [dict get $indeviceinfo localchan] + + #NOTE:These transforms are not necessarily at the top of each stack! + #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. + set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] + set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] + + # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this + # If non os-level channel - the command can't be run with the redirection + # stderr/stdout can be run with non-os handles in the call - + # but then it does introduce issues with terminal-detection and behaviour for stdout at least + # + # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. + # + #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] + + + #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] + #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] + + #we need to catch errors - and ensure stack::remove calls occur. + #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. + # + if {!$is_script} { + set experiment 0 + if $experiment { + try { + set results [exec {*}$commandlist] + set exitinfo [list exitcode 0] + } trap CHILDSTATUS {results options} { + set exitcode [lindex [dict get $options -errorcode] 2] + set exitinfo [list exitcode $exitcode] + } + } else { + if {[catch { + #run process with stdout/stderr/stdin or with configured channels + #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] + set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] + #puts stderr "---->exitinfo $exitinfo" + + #subprocess result should usually have an "exitcode" key + #but for background execution we will get a "pids" key of process ids. + } errMsg]} { + set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] + } + } + } else { + if {[catch { + #script result + set exitinfo [list result [uplevel #0 [list eval $commandlist]]] + } errMsg]} { + set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] + } + } + + + #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal + #Remove execution-time Tees from stack + shellfilter::stack::remove stdout $id_out + shellfilter::stack::remove stderr $id_err + #shellfilter::stack::remove stderr $id_in + + + #chan configure stderr -buffering line + #flush stdout + + + ::shellfilter::log::write $runtag " return '$exitinfo'" + ::shellfilter::log::close $runtag + return $exitinfo + } + proc ::shellfilter::logtidyup { {tags {}} } { + variable sources + set worker_errorlist [list] + set tidied_sources [list] + set tidytag "logtidy" + set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] + ::shellfilter::log::write $tidytag " logtidyuptags '$tags'" + foreach s $sources { + if {$s eq $tidytag} { + continue + } + #puts "logtidyup source $s" + set close 1 + if {[llength $tags]} { + if {$s ni $tags} { + set close 0 + } + } + if {$close} { + lappend tidied_sources $s + shellfilter::log::close $s + lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] + } + } + set remaining_sources [list] + foreach s $sources { + if {$s ni $tidied_sources} { + lappend remaining_sources $s + } + } + set sources [concat $remaining_sources $tidytag] + #shellfilter::stack::unwind stdout + #shellfilter::stack::unwind stderr + return [list tidied $tidied_sources errors $worker_errorlist] + } + + #package require tcl::chan::null + # e.g set errchan [tcl::chan::null] + # e.g chan push stdout [shellfilter::chan::var new ::some_var] + proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { + set valid_flags [list \ + -timeout \ + -outprefix \ + -errprefix \ + -debug \ + -copytempfile \ + -outbuffering \ + -errbuffering \ + -inbuffering \ + -readprocesstranslation \ + -outtranslation \ + -stdinhandler \ + -outchan \ + -errchan \ + -inchan \ + -teehandle\ + ] + + set runtag shellfilter-run2 + #JMN - load from config + #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] + set tid [::shellfilter::log::open $runtag [list -syslog ""]] + + if {([llength $args] % 2) != 0} { + error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" + } + set invalid_flags [list] + foreach k [dict keys $args] { + if {$k ni $valid_flags} { + lappend invalid_flags $k + } + } + if {[llength $invalid_flags]} { + error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" + } + #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order + #there may be data where line buffering is inappropriate, so it's configurable per std channel + #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. + set defaults [dict create \ + -outchan stdout \ + -errchan stderr \ + -inchan stdin \ + -outbuffering none \ + -errbuffering none \ + -readprocesstranslation auto \ + -outtranslation lf \ + -inbuffering none \ + -timeout 900000\ + -outprefix ""\ + -errprefix ""\ + -debug 0\ + -copytempfile 0\ + -stdinhandler ""\ + ] + + + + set args [dict merge $defaults $args] + set outbuffering [dict get $args -outbuffering] + set errbuffering [dict get $args -errbuffering] + set inbuffering [dict get $args -inbuffering] + set readprocesstranslation [dict get $args -readprocesstranslation] + set outtranslation [dict get $args -outtranslation] + set timeout [dict get $args -timeout] + set outprefix [dict get $args -outprefix] + set errprefix [dict get $args -errprefix] + set debug [dict get $args -debug] + set copytempfile [dict get $args -copytempfile] + set stdinhandler [dict get $args -stdinhandler] + + set debugname "shellfilter-debug" + + if {$debug} { + set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] + ::shellfilter::log::write $debugname " commandlist '$commandlist'" + } + #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. + # a simple counter would probably work too + #consider other options if an alternative to the single vwait in this function is used. + set call_id [clock micros] ; + set ::shellfilter::shellcommandvars($call_id,exitcode) "" + set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) + if {$debug} { + ::shellfilter::log::write $debugname " waitvar '$waitvar'" + } + lassign [chan pipe] rderr wrerr + chan configure $wrerr -blocking 0 + + set lastitem [lindex $commandlist end] + #todo - ensure we can handle 2> file (space after >) + + if {[string trim [lindex $commandlist end]] eq "&"} { + set name [lindex $commandlist 0] + #background execution - stdout and stderr from child still comes here - but process is backgrounded + #FIX! - this is broken for paths with backslashes for example + #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] + set pidlist [exec {*}$commandlist] + return [list pids $pidlist] + } + + #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! + # + #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere + #(2>@stdout echoes to main stdout - not into pipeline) + #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) + set custom_stderr "" + if {[string trim $lastitem] in [list {2>&1} {2>@1}]} { + set custom_stderr {2>@1} ;#use the tcl style + set commandlist [lrange $commandlist 0 end-1] + } else { + # 2> filename + # 2>> filename + # 2>@ openfileid + set redir2test [string range $lastitem 0 1] + if {$redir2test eq "2>"} { + set custom_stderr $lastitem + set commandlist [lrange $commandlist 0 end-1] + } + } + set lastitem [lindex $commandlist end] + + set teefile "" ;#empty string, write, append + #an ugly hack.. because redirections seem to arrive wrapped - review! + #There be dragons here.. + #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. + #The problem here - is that we can't always know what was intended on the commandline regarding quoting + + ::shellfilter::log::write $runtag "checking for redirections in $commandlist" + #sometimes we see a redirection without a following space e.g >C:/somewhere + #normalize + if {[regexp {^>[/[:alpha:]]+} $lastitem]} { + set lastitem "> [string range $lastitem 1 end]" + } + if {[regexp {^>>[/[:alpha:]]+} $lastitem]} { + set lastitem ">> [string range $lastitem 2 end]" + } + + #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} + #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} + #we can't use list methods such as llenth on a member of commandlist + set wordlike_parts [regexp -inline -all {\S+} $lastitem] + + if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { + #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) + set lastitem [string trim $lastitem] ;#we often see { > something} + + #don't use lassign or lrange on the element itself without checking first + #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. + #lassign $lastitem redir redirtarget + #set commandlist [lrange $commandlist 0 end-1] + # + set itemchars [split $lastitem ""] + set firstchar [lindex $itemchars 0] + set lastchar [lindex $itemchars end] + + #NAIVE test for double quoted only! + #consider for example {"a" x="b"} + #testing first and last is not decisive + #We need to decide what level of drilling down is even appropriate here.. + #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) + set head_tail_chars [list $firstchar $lastchar] + set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] + if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { + set curlyquoted 1 + } else { + set curlyquoted 0 + } + + if {$curlyquoted} { + #these are not the tcl protection brackets but ones supplied in the argument + #it's still not valid to use list operations on a member of the commandlist + set inner [string range $lastitem 1 end-1] + #todo - fix! we still must assume there could be list-breaking data! + set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char + set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below + set redirtarget [lrange $innerwords 1 end] ;#all the rest + } elseif {$doublequoted} { + ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" + set inner [string range $lastitem 1 end-1] + set innerwords [regexp -inline -all {\S+} $inner] + set redir [lindex $innerwords 0] + set redirtarget [lrange $innerwords 1 end] + } else { + set itemwords [regexp -inline -all {\S+} $lastitem] + # e.g > c:\test becomes > {c:\test} + # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt + set redir [lindex $itemwords 0] + set redirtarget [lrange $itemwords 1 end] + } + set commandlist [lrange $commandlist 0 end-1] + + } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { + #unwrapped redirection + #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list + set redir [lindex $commandlist end-1] + set redirtarget [lindex $commandlist end] + set commandlist [lrange $commandlist 0 end-2] + } else { + #no redirection + set redir "" + set redirtarget "" + #no change to command list + } + + + + if {$redir in [list ">>" ">"]} { + set redirtarget [string trim $redirtarget "\""] + ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" + + + set winfile $redirtarget ;#default assumption + if {[string match "/c/*" $redirtarget]} { + set winfile "c:/[string range $redirtarget 3 end]" + } + if {[string match "/mnt/c/*" $redirtarget]} { + set winfile "c:/[string range $redirtarget 7 end]" + } + + if {[file exists [file dirname $winfile]]} { + #containing folder for target exists + if {$redir eq ">"} { + set teefile "write" + } else { + set teefile "append" + } + ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" + + } else { + #we should be writing to a file.. but can't + ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" + + } + } else { + ::shellfilter::log::write $runtag "No redir found!!" + } + #often first element of command list is wrapped and cannot be run directly + #e.g {{ls -l} {> {temp.tmp}}} + #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. + # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. + #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) + set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] + + #todo? + #child process environment. + # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. + + #to restore buffering states after run + set remember_in_out_err_buffering [list \ + [chan configure $inchan -buffering] \ + [chan configure $outchan -buffering] \ + [chan configure $errchan -buffering] \ + ] + + set remember_in_out_err_translation [list \ + [chan configure $inchan -translation] \ + [chan configure $outchan -translation] \ + [chan configure $errchan -translation] \ + ] + + + + + + chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok + chan configure $errchan -buffering $errbuffering + #chan configure $outchan -blocking 0 + chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. + # + + #-------------------------------------------- + #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto + #cmd, pwsh, tcl + #chan configure $outchan -translation lf + #chan configure $errchan -translation lf + #-------------------------------------------- + chan configure $outchan -translation $outtranslation + chan configure $errchan -translation $outtranslation + + #puts stderr "chan configure $wrerr [chan configure $wrerr]" + if {$debug} { + ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" + } + #todo - handle custom redirection of stderr to a file? + if {[string length $custom_stderr]} { + #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" + #set rdout [open |[concat $commandlist $custom_stderr] a+] + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" + set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] + set rderr "bogus" ;#so we don't wait for it + } else { + ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] + #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] + + # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. + # This is the whole reason we need these file-event loops. + # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination + # - and that at least appears like a terminal to the called command. + #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] + + + set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] + + chan configure $rderr -buffering $errbuffering -blocking 0 + chan configure $rderr -translation $readprocesstranslation + } + + + + set command_pids [pid $rdout] + #puts stderr "command_pids: $command_pids" + #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway + # the child process generally won't shut down until channels are closed. + # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. + # worked around in punk/repl using 'script' command as a fake tty. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $command_pids 0] ni $subprocesses} { + # puts stderr "pid [lindex $command_pids 0] not running $errMsg" + #} else { + # puts stderr "pid [lindex $command_pids 0] is running" + #} + + + if {$debug} { + ::shellfilter::log::write $debugname "pipeline pids: $command_pids" + } + + #jjj + + + chan configure $rdout -buffering $outbuffering -blocking 0 + chan configure $rdout -translation $readprocesstranslation + + if {![string length $custom_stderr]} { + chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { + if {$errbuffering eq "line"} { + set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #errprefix only applicable to line buffered output + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $errchan ${errprefix}$chunk + } else { + puts $errchan "${errprefix}$chunk" + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $errchan $chunk + } + } + if {[chan eof $chan]} { + flush $errchan ;#jmn + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" + #} else { + # puts stderr "stderr reader: pid [lindex $pids 0] still running" + #} + chan close $chan + #catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stderr + } + } + }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] + } + + #todo - handle case where large amount of stdin coming in faster than rdout can handle + #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable + # - we're just pumping it in to the non-blocking rdout buffers + # ie there is no backpressure and stdin will suck in as fast as possible. + # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc + # + # + + ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable + # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. + # Not known if that is significant + ## with inchan configured -buffering line + #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl -r cat + #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:1 pend:-1 count:3 + #etc + + if 0 { + chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { + #chan copy stdin $chan ;#doesn't work in a chan event + if {$inbuffering eq "line"} { + set countchunk [chan gets $chan chunk] + #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {[chan eof $chan]} { + puts -nonewline $wrchan $chunk + } else { + puts $wrchan $chunk + } + } + } else { + set chunk [chan read $chan] + if {[string length $chunk]} { + puts -nonewline $wrchan $chunk + } + } + if {[chan eof $chan]} { + puts stderr "|stdin_reader>eof [chan configure stdin]" + chan event $chan readable {} + #chan close $chan + chan close $wrchan write ;#half close + #set $waitfor "stdin" + } + }} $inchan $rdout $inbuffering $waitvar] + + if {[string length $stdinhandler]} { + chan configure stdin -buffering line -blocking 0 + chan event stdin readable $stdinhandler + } + } + + set actual_proc_out_buffering [chan configure $rdout -buffering] + set actual_outchan_buffering [chan configure $outchan -buffering] + #despite whatever is configured - we match our reading to how we need to output + set read_proc_out_buffering $actual_outchan_buffering + + + + if {[string length $teefile]} { + set logname "redir_[string map [list : _ ] $winfile]_[clock micros]" + set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] + if {$teefile eq "write"} { + ::shellfilter::log::write $logname "opening '$winfile' for write" + set fd [open $winfile w] + } else { + ::shellfilter::log::write $logname "opening '$winfile' for appending" + set fd [open $winfile a] + } + #chan configure $fd -translation lf + chan configure $fd -translation $outtranslation + chan configure $fd -encoding utf-8 + + set tempvar_bytetotal [namespace current]::totalbytes[clock micros] + set $tempvar_bytetotal 0 + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { + #review - if we write outprefix to normal stdout.. why not to redirected file? + #usefulness of outprefix is dubious + upvar $bytevar totalbytes + if {$read_proc_out_buffering eq "line"} { + #set outchunk [chan read $chan] + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + if {$countchunk >= 0} { + if {![chan eof $chan]} { + set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review + puts $writefilefd $outchunk + } else { + set numbytes [string length $outchunk] + puts -nonewline $writefilefd $outchunk + } + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" + } + } else { + set outchunk [chan read $chan] + if {[string length $outchunk]} { + puts -nonewline $writefilefd $outchunk + set numbytes [string length $outchunk] + incr totalbytes $numbytes + ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" + } + } + if {[chan eof $chan]} { + flush $writefilefd ;#jmn + #set blocking so we can get exit code + chan configure $chan -blocking 1 + catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} + #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" + catch {close $writefilefd} + if {$copytempfile} { + catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} + } + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } + catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stdout + } + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] + + } else { + + # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' + # where b:0|1 is whether chan blocked $chan returns 0 or 1 + # pend is the result of chan pending $chan + # eof is the resot of chan eof $chan + + + ##------------------------- + ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none + ## then we can detect the difference + # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. + #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl /u/c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:1 eof:0 pend:-1 count:-1 + #instate b:0 eof:1 pend:-1 count:3 + #etc + ##------------------------ + + + #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. + ###reading with gets from line buffered input with trailing newline + #c:\repo\jn\shellspy\test>printf "test\netc\n" | tclsh shellspy.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + + ###reading with gets from line buffered input with trailing newline + ##No detectable difference! + #c:\repo\jn\shellspy\test>printf "test\netc" | tclsh shellspy.vfs/main.tcl /c cat + #instate b:0 eof:0 pend:-1 count:4 + #test + #instate b:0 eof:0 pend:-1 count:3 + #etc + #instate b:0 eof:1 pend:-1 count:-1 + ##------------------------- + + #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is + + + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important + #this detection is disabled for now - but left for debugging in case it means something.. or changes + chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { + #set outchunk [chan read $chan] + + if {$read_proc_out_buffering eq "line"} { + set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved + #countchunk can be -1 before eof e.g when blocked + #debugging output inline with data - don't leave enabled + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + if {$countchunk >= 0} { + if {![chan eof $chan]} { + puts $outchan ${outprefix}$outchunk + } else { + puts -nonewline $outchan ${outprefix}$outchunk + #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { + # seems to be the usual case + #} else { + # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior + # #Not known if this occurs + # #debugging output inline with data - don't leave enabled + # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" + #} + } + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 + } else { + #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] + } + } else { + #puts $outchan "read CHANNEL $chan [chan configure $chan]" + #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" + set outchunk [chan read $chan] + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" + if {[string length $outchunk]} { + #set stringrep [encoding convertfrom utf-8 $outchunk] + #set newbytes [encoding convertto utf-16 $stringrep] + #puts -nonewline $outchan $newbytes + puts -nonewline $outchan $outchunk + } + } + + if {[chan eof $chan]} { + flush $outchan ;#jmn + #for now just look for first element in the pid list.. + #set subprocesses [tcl::process::list] + #puts stderr "subprocesses: $subprocesses" + #if {[lindex $pids 0] ni $subprocesses} { + # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" + #} else { + # puts stderr "stdout reader pid: [lindex $pids 0] still running" + #} + + #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" + chan configure $chan -blocking 1 ;#so we can get exit code + try { + chan close $chan + set ::shellfilter::shellcommandvars($call_id,exitcode) 0 + if {$debug} { + ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {$debug} { + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars($call_id,exitcode) $code + } trap CHILDKILLED {result options} { + #set code [lindex [dict get $options -errorcode] 2] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" + ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" + + } finally { + #puts stdout "HERE" + #flush stdout + + } + catch {chan close $wrerr} + if {$other ni [chan names]} { + set $waitfor stdout + } + + } + }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] + } + + #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data + #e.g x hrs with no data(?) + #reset timeout when data detected. + after $timeout [string map [list %w $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { + if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { + if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { + catch { chan close %wrerr% } + catch { chan close %rdout%} + catch { chan close %rderr%} + } else { + chan configure %rdout% -blocking 1 + try { + chan close %rdout% + set ::shellfilter::shellcommandvars(%id%,exitcode) 0 + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" + } + } trap CHILDSTATUS {result options} { + set code [lindex [dict get $options -errorcode] 2] + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" + } + set ::shellfilter::shellcommandvars(%id%,exitcode) $code + } trap CHILDKILLED {result options} { + set code [lindex [dict get $options -errorcode] 2] + #set code [dict get $options -code] + #set ::shellfilter::shellcommandvars(%id%,exitcode) $code + set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" + if {%debug%} { + ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" + ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" + } + + } + catch { chan close %wrerr% } + catch { chan close %rderr%} + + } + set %w "timeout" + } + }] + + + vwait $waitvar + + set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] + if {![string is digit -strict $exitcode]} { + puts stderr "Process exited with non-numeric code: $exitcode" + flush stderr + } + if {[string length $teefile]} { + #cannot be called from within an event handler above.. vwait reentrancy etc + catch {::shellfilter::log::close $logname} + } + + if {$debug} { + ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" + catch {::shellfilter::log::close $debugname} + } + array unset ::shellfilter::shellcommandvars $call_id,* + + + #restore buffering to pre shellfilter::run state + lassign $remember_in_out_err_buffering bin bout berr + chan configure $inchan -buffering $bin + chan configure $outchan -buffering $bout + chan configure $errchan -buffering $berr + + lassign $remember_in_out_err_translation tin tout terr + chan configure $inchan -translation $tin + chan configure $outchan -translation $tout + chan configure $errchan -translation $terr + + + #in channel probably closed..(? review - should it be?) + catch { + chan configure $inchan -buffering $bin + } + + + return [list exitcode $exitcode] + } + +} + +package provide shellfilter [namespace eval shellfilter { + variable version + set version 0.1.8 +}] diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellrun-0.1.tm b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellrun-0.1.tm new file mode 100644 index 00000000..5988ec40 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellrun-0.1.tm @@ -0,0 +1,710 @@ +# vim: set ft=tcl +# +#purpose: handle the run commands that call shellfilter::run +#e.g run,runout,runerr,runx + +package require shellfilter +package require punk::ansi + +#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. +# - If it did run, but there was a non-zero exitcode it is up to the application to check that. +#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. +#The user can always use exec for different process error semantics (they don't get exitcode with exec) + +namespace eval shellrun { + variable runout + variable runerr + + #do we need these? + variable punkout + variable punkerr + + #some ugly coupling with punk/punk::config for now + #todo - something better + if {[info exists ::punk::config::running]} { + upvar ::punk::config::running conf + set syslog_stdout [dict get $conf syslog_stdout] + set syslog_stderr [dict get $conf syslog_stderr] + set logfile_stdout [dict get $conf logfile_stdout] + set logfile_stderr [dict get $conf logfile_stderr] + } else { + lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr + } + set outdevice [shellfilter::stack::new punkout -settings [list -tag "punkout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] + set out [dict get $outdevice localchan] + set errdevice [shellfilter::stack::new punkerr -settings [list -tag "punkerr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] + set err [dict get $errdevice localchan] + + namespace import ::punk::ansi::a+ + namespace import ::punk::ansi::a + + + + + #repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen + #todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. + #somewhat strong coupling to punk - but let's try to behave decently if it's not loaded + #The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. + proc set_last_run_display {chunklist} { + #chunklist as understood by the + if {![info exists ::punk::repltelemetry_emmitters]} { + namespace eval ::punk { + variable repltelemetry_emmitters + set repltelemetry_emmitters "shellrun" + } + } else { + if {"shellrun" ni $::punk::repltelemetry_emmitters} { + lappend punk::repltelemetry_emmitters "shellrun" + } + } + + #most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info + if {[catch {llength $chunklist} errMsg]} { + error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" + } + #todo - + set ::punk::last_run_display $chunklist + } + + + + #maintenance: similar used in punk::ns & punk::winrun + #todo - take runopts + aliases as args + proc get_run_opts {arglist} { + if {[catch { + set callerinfo [info level -1] + } errM]} { + set caller "" + } else { + set caller [lindex $callerinfo 0] + } + + #we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value + #This is for compatibility with other runX commands, and the difference is also visible when calling from repl. + set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl"] ;#include map to self + set runopts [list] + set cmdargs [list] + set idx_first_cmdarg [lsearch -not $arglist "-*"] + set runopts [lrange $arglist 0 $idx_first_cmdarg-1] + set cmdargs [lrange $arglist $idx_first_cmdarg end] + foreach o $runopts { + if {$o ni $known_runopts} { + error "$caller: Unknown runoption $o - known options $known_runopts" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + return [list runopts $runopts cmdargs $cmdargs] + } + + + + proc run {args} { + set_last_run_display [list] + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + set idlist_stderr [list] + #we leave stdout without imposed ansi colouring - because the source may be colourised + #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr is very handy for the run command. + #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, + #but defaulting stderr to red is a pretty reasonable compromise. + #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. + #TODO - fix. This has no effect because the repl adds an ansiwrap transform + # what we probably want to do is 'aside' that transform for runxxx commands only. + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + + set callopts [dict create] + if {"-tcl" in $runopts} { + dict set callopts -tclscript 1 + } + #--------------------------------------------------------------------------------------------- + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punk -inbuffering none -outbuffering none ] + #--------------------------------------------------------------------------------------------- + + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + error "[dict get $exitinfo error]\n$exitinfo" + } + + return $exitinfo + } + + proc runout {args} { + set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #puts stdout "RUNOUT cmdargs: $cmdargs" + + #todo add -data boolean and -data lastwrite to -settings with default being -data all + # because sometimes we're only interested in last char (e.g to detect something was output) + + #set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] + # + #when not echoing - use float-locked so that the repl's stack is bypassed + if {"-echo" in $runopts} { + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + #set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] + } else { + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + + #shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punk -inbuffering none -outbuffering none ] + + flush stderr + flush stdout + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + #shellfilter::stack::remove commandout $outvar_stackid + + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #we must raise an error. + #todo - check errorInfo makes sense.. return -code? tailcall? + # + set msg "" + append msg [dict get $exitinfo error] + append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" + error $msg + } + } + + set chunklist [list] + + #exitcode not part of return value for runout - colourcode appropriately + set n [a] + set c "" + if [dict exists $exitinfo exitcode] { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + lappend chunklist [list "info" "$c$exitinfo$n"] + } elseif [dict exists $exitinfo error] { + set c [a+ yellow bold] + lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + #lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] + } else { + set c [a+ Yellow red bold] + lappend chunklist [list "info" "$c$exitinfo$n"] + } + + + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + #append chunk "[a+ red light]$e[a]\n" + append chunk "[a+ red light]$e[a]" + } + lappend chunklist [list stderr $chunk] + + + + + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "$o" + } + lappend chunklist [list result $chunk] + + + set_last_run_display $chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runout \r\n] + } else { + return $::shellrun::runout + } + } + + proc runerr {args} { + set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + if {"-echo" in $runopts} { + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] + } else { + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] + } + + + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + shellfilter::stack::remove stderr $stderr_stackid + shellfilter::stack::remove stdout $stdout_stackid + + + flush stderr + flush stdout + + #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch + # to determine something other than just a nonzero exit code or output on stderr. + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + set chunklist [list] + + set n [a] + set c "" + if [dict exists $exitinfo exitcode] { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + + lappend chunklist [list "info" "$c$exitinfo$n"] + + } elseif [dict exists $exitinfo error] { + set c [a+ yellow bold] + lappend chunklist [list "info" "error [dict get $exitinfo error]"] + lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] + lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] + } else { + set c [a+ Yellow red bold] + lappend chunklist [list "info" "$c$exitinfo$n"] + } + + + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + append chunk "[a+ white light]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + } + lappend chunklist [list stdout $chunk] + + + + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "info" $chunk] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + append chunk "$e" + } + lappend chunklist [list resulterr $chunk] + + + set_last_run_display $chunklist + + if {$nonewline} { + return [string trimright $::shellrun::runerr \r\n] + } + return $::shellrun::runerr + } + + + proc runx {args} { + set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + + if {"-nonewline" in $runopts} { + set nonewline 1 + } else { + set nonewline 0 + } + + #shellfilter::stack::remove stdout $::repl::id_outstack + + if {"-echo" in $runopts} { + #float to ensure repl transform doesn't interfere with the output data + set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + } else { + #set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] + #set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] + + #float above the repl's tee_to_var to deliberately block it. + #a var transform is naturally a junction point because there is no flow-through.. + # - but mark it with -junction 1 just to be explicit + set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] + set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] + } + + set callopts "" + if {"-tcl" in $runopts} { + append callopts " -tclscript 1" + } + #set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punk -inbuffering none -outbuffering none] + + shellfilter::stack::remove stdout $stdout_stackid + shellfilter::stack::remove stderr $stderr_stackid + + + flush stderr + flush stdout + + if {[dict exists $exitinfo error]} { + if {"-tcl" in $runopts} { + + } else { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + } + + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] + + set chunk "" + if {[string length $::shellrun::runout]} { + if {$nonewline} { + set o [string trimright $::shellrun::runout \r\n] + } else { + set o $::shellrun::runout + } + set chunk $o + } + set chunklist [list] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output + lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict + + + lappend chunklist [list "info" " "] + set chunk "[a+ red bold]stderr[a]" + lappend chunklist [list "result" $chunk] + lappend chunklist [list "info" stderr] + + set chunk "" + if {[string length $::shellrun::runerr]} { + if {$nonewline} { + set e [string trimright $::shellrun::runerr \r\n] + } else { + set e $::shellrun::runerr + } + set chunk $e + } + #stderr is part of the result + lappend chunklist [list "resulterr" $chunk] + + + + set n [a] + set c "" + if {[dict exists $exitinfo exitcode]} { + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ yellow bold] + } + lappend chunklist [list "info" " "] + lappend chunklist [list "result" exitcode] + lappend chunklist [list "info" "exitcode $code"] + lappend chunklist [list "result" "$c$code$n"] + set exitdict [list exitcode $code] + } elseif {[dict exists $exitinfo result]} { + # presumably from a -tcl call + set val [dict get $exitinfo result] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" result] + lappend chunklist [list "info" result] + lappend chunklist [list "result" $val] + set exitdict [list result $val] + } elseif {[dict exists $exitinfo error]} { + # -tcl call with error + #set exitdict [dict create] + lappend chunklist [list "info" " "] + lappend chunklist [list "result" error] + lappend chunklist [list "info" error] + lappend chunklist [list "result" [dict get $exitinfo error]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorCode] + lappend chunklist [list "info" errorCode] + lappend chunklist [list "result" [dict get $exitinfo errorCode]] + + lappend chunklist [list "info" " "] + lappend chunklist [list "result" errorInfo] + lappend chunklist [list "info" errorInfo] + lappend chunklist [list "result" [dict get $exitinfo errorInfo]] + + set exitdict $exitinfo + } else { + #review - if no exitcode or result. then what is it? + lappend chunklist [list "info" exitinfo] + set c [a+ yellow bold] + lappend chunklist [list result "$c$exitinfo$n"] + set exitdict [list exitinfo $exitinfo] + } + + set_last_run_display $chunklist + + #set ::repl::result_print 0 + #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] + + + if {$nonewline} { + return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] + } + #always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) + return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] + } + + #an experiment + # + #run as raw string instead of tcl-list - no variable subst etc + # + #dummy repl_runraw that repl will intercept + proc repl_runraw {args} { + error "runraw: only available in repl as direct call - not from script" + } + #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) + proc runraw {commandline} { + #runraw fails as intended - because we can't bypass exec/open interference quoting :/ + set_last_run_display [list] + variable runout + variable runerr + set runout "" + set runerr "" + + #return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] + puts stdout ">>runraw got: $commandline" + + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing + #for consistency with other runxxx commands - we'll just consume it. (review) + + set reallyraw 1 + if {$reallyraw} { + set wordparts [regexp -inline -all {\S+} $commandline] + set runwords $wordparts + } else { + #shell style args parsing not suitable for windows where we can't assume matched quotes etc. + package require string::token::shell + set parts [string token shell -indices -- $commandline] + puts stdout ">>shellparts: $parts" + set runwords [list] + foreach p $parts { + set ptype [lindex $p 0] + set pval [lindex $p 3] + if {$ptype eq "PLAIN"} { + lappend runwords [lindex $p 3] + } elseif {$ptype eq "D:QUOTED"} { + set v {"} + append v $pval + append v {"} + lappend runwords $v + } elseif {$ptype eq "S:QUOTED"} { + set v {'} + append v $pval + append v {'} + lappend runwords $v + } + } + } + + puts stdout ">>runraw runwords: $runwords" + set runwords [lrange $runwords 1 end] + + puts stdout ">>runraw runwords: $runwords" + #set args [lrange $args 1 end] + #set runwords [lrange $wordparts 1 end] + + set known_runopts [list "-echo" "-e" "-terminal" "-t"] + set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self + set runopts [list] + set cmdwords [list] + set idx_first_cmdarg [lsearch -not $runwords "-*"] + set runopts [lrange $runwords 0 $idx_first_cmdarg-1] + set cmdwords [lrange $runwords $idx_first_cmdarg end] + + foreach o $runopts { + if {$o ni $known_runopts} { + error "runraw: Unknown runoption $o" + } + } + set runopts [lmap o $runopts {dict get $aliases $o}] + + set cmd_as_string [join $cmdwords " "] + puts stdout ">>cmd_as_string: $cmd_as_string" + + if {"-terminal" in $runopts} { + #fake terminal using 'script' command. + #not ideal: smushes stdout & stderr together amongst other problems + set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] + puts stdout ">>tcmd: $tcmd" + set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ] + set exitinfo "exitcode not-implemented" + } else { + set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ] + } + + if {[dict exists $exitinfo error]} { + #todo - check errorInfo makes sense.. return -code? tailcall? + error [dict get $exitinfo error] + } + set code [dict get $exitinfo exitcode] + if {$code == 0} { + set c [a+ green] + } else { + set c [a+ white bold] + } + puts stderr $c + return $exitinfo + } + + proc sh_run {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + #e.g sh -c "ls -l *" + #we pass cmdargs to sh -c as a list, not individually + tailcall shellrun::run {*}$runopts sh -c $cmdargs + } + proc sh_runout {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runout {*}$runopts sh -c $cmdargs + } + proc sh_runerr {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runerr {*}$runopts sh -c $cmdargs + } + proc sh_runx {args} { + set splitargs [get_run_opts $args] + set runopts [dict get $splitargs runopts] + set cmdargs [dict get $splitargs cmdargs] + tailcall shellrun::runx {*}$runopts sh -c $cmdargs + } +} + +namespace eval shellrun { + interp alias {} run {} shellrun::run + interp alias {} sh_run {} shellrun::sh_run + interp alias {} runout {} shellrun::runout + interp alias {} sh_runout {} shellrun::sh_runout + interp alias {} runerr {} shellrun::runerr + interp alias {} sh_runerr {} shellrun::sh_runerr + interp alias {} runx {} shellrun::runx + interp alias {} sh_runx {} shellrun::sh_runx + + interp alias {} runraw {} shellrun::runraw + + + #the shortened versions deliberately don't get pretty output from the repl + interp alias {} r {} shellrun::run + interp alias {} ro {} shellrun::runout + interp alias {} re {} shellrun::runerr + interp alias {} rx {} shellrun::runx + + +} + +namespace eval shellrun { + proc test_cffi {} { + package require test_cffi + cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] + ::shellrun::kernel32 stdcall CreateProcessA + #todo - stuff. + return ::shellrun::kernel32 + } + +} + +package provide shellrun [namespace eval shellrun { + variable version + set version 0.1 +}] diff --git a/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm new file mode 100644 index 00000000..574dbda5 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/sample.vfs/modules/shellthread-1.6.tm @@ -0,0 +1,698 @@ +#package require logger + +package provide shellthread [namespace eval shellthread { + variable version + set version 1.6 +}] + + +package require Thread + +namespace eval shellthread { + + proc iso8601 {{tsmicros ""}} { + if {$tsmicros eq ""} { + set tsmicros [clock micros] + } else { + set microsnow [clock micros] + if {[string length $tsmicros] != [string length $microsnow]} { + error "iso8601 requires 'clock micros' or empty string to create timestamp" + } + } + set seconds [expr {$tsmicros / 1000000}] + return [clock format $seconds -format "%Y-%m-%d_%H-%M-%S"] + } +} + +namespace eval shellthread::worker { + variable settings + variable sysloghost_port + variable sock + variable logfile "" + variable fd + variable client_ids [list] + variable ts_start_micros + variable errorlist [list] + variable inpipe "" + + proc bgerror {args} { + variable errorlist + lappend errorlist $args + } + proc send_errors_now {tidcli} { + variable errorlist + thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] + } + proc add_client_tid {tidcli} { + variable client_ids + if {$tidcli ni $client_ids} { + lappend client_ids $tidcli + } + } + proc init {tidclient start_m settingsdict} { + variable sysloghost_port + variable logfile + variable settings + interp bgerror {} shellthread::worker::bgerror + package require overtype + variable client_ids + variable ts_start_micros + lappend client_ids $tidclient + set ts_start_micros $start_m + + set defaults [list -raw 0 -file "" -syslog "" -direction out] + set settings [dict merge $defaults $settingsdict] + + set syslog [dict get $settings -syslog] + if {[string length $syslog]} { + lassign [split $syslog :] s_host s_port + set sysloghost_port [list $s_host $s_port] + } else { + set sysloghost_port "" + } + if {[catch {package require udp} errm]} { + #disable rather than bomb and interfere with any -file being written + set sysloghost_port "" + } + + set logfile [dict get $settings -file] + } + + proc start_pipe_read {source readchan args} { + #assume 1 inpipe for now + variable inpipe + variable sysloghost_port + variable logfile + set defaults [dict create -buffering \uFFFF ] + set opts [dict merge $defaults $args] + if {[dict exists $opts -readbuffering]} { + set readbuffering [dict get $opts -readbuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + #get buffering setting from the channel as it was set prior to thread::transfer + set readbuffering [chan configure $readchan -buffering] + } else { + set readbuffering [dict get $opts -buffering] + chan configure $readchan -buffering $readbuffering + } + } + if {[dict exists $opts -writebuffering]} { + set writebuffering [dict get $opts -writebuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + set writebuffering line + #set writebuffering [chan configure $writechan -buffering] + } else { + set writebuffering [dict get $opts -buffering] + #can configure $writechan -buffering $writebuffering + } + } + + chan configure $readchan -translation lf + + if {$readchan ni [chan names]} { + error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" + } + set inpipe $readchan + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO\n" line + chan configure $readchan -blocking 0 + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO2 readbuffering: $readbuffering syslog $sysloghost_port filename $logfile" line + + set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) + chan event $readchan readable [list apply {{chan source waitfor readbuffering writebuffering} { + if {$readbuffering eq "line"} { + set chunksize [chan gets $chan chunk] + if {$chunksize >= 0} { + if {![chan eof $chan]} { + ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering + } else { + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + } + } + } else { + set chunk [chan read $chan] + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + } + if {[chan eof $chan]} { + chan event $chan readable {} + set $waitfor "pipe" + chan close $chan + } + }} $readchan $source $waitvar $readbuffering $writebuffering] + #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO3 vwaiting on $waitvar\n" line + vwait $waitvar + } + + proc start_pipe_write {source writechan args} { + variable outpipe + set defaults [dict create -buffering \uFFFF ] + set opts [dict merge $defaults $args] + + #todo! + set readchan stdin + + if {[dict exists $opts -readbuffering]} { + set readbuffering [dict get $opts -readbuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + set readbuffering [chan configure $readchan -buffering] + } else { + set readbuffering [dict get $opts -buffering] + chan configure $readchan -buffering $readbuffering + } + } + if {[dict exists $opts -writebuffering]} { + set writebuffering [dict get $opts -writebuffering] + } else { + if {[dict get $opts -buffering] eq "\uFFFF"} { + #nothing explicitly set - take from transferred channel + set writebuffering [chan configure $writechan -buffering] + } else { + set writebuffering [dict get $opts -buffering] + can configure $writechan -buffering $writebuffering + } + } + + if {$writechan ni [chan names]} { + error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" + } + set outpipe $writechan + chan configure $readchan -blocking 0 + chan configure $writechan -blocking 0 + set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) + + chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { + if {$readbuffering eq "line"} { + set chunksize [chan gets $chan chunk] + if {$chunksize >= 0} { + if {![chan eof $chan]} { + puts $writechan $chunk + } else { + puts -nonewline $writechan $chunk + } + } + } else { + set chunk [chan read $chan] + puts -nonewline $writechan $chunk + } + if {[chan eof $chan]} { + chan event $chan readable {} + set $waitfor "pipe" + chan close $writechan + if {$chan ne "stdin"} { + chan close $chan + } + } + }} $readchan $writechan $source $waitvar $readbuffering] + + vwait $waitvar + } + + + proc _initsock {} { + variable sysloghost_port + variable sock + if {[string length $sysloghost_port]} { + if {[catch {fconfigure $sock} state]} { + set sock [udp_open] + fconfigure $sock -buffering none -translation binary + fconfigure $sock -remote $sysloghost_port + } + } + } + proc _reconnect {} { + variable sock + catch {close $sock} + _initsock + return [fconfigure $sock] + } + + proc send_info {client_tid ts_sent source msg} { + set ts_received [clock micros] + set lag_micros [expr {$ts_received - $ts_sent}] + set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds + + log $client_tid $ts_sent $lag $source - info $msg line 1 + } + proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { + variable sock + variable fd + variable sysloghost_port + variable logfile + variable settings + + set logchunk $msg + + if {![dict get $settings -raw]} { + set tail_crlf 0 + set tail_lf 0 + set tail_cr 0 + #for cooked - always remove the trailing newline before splitting.. + # + #note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. + # + #Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split + #but add it back exactly as it was afterwards + #we can always split on \n - and any adjacent \r will be preserved in the rejoin + set lastchar [string range $logchunk end end] + if {[string range $logchunk end-1 end] eq "\r\n"} { + set tail_crlf 1 + set logchunk [string range $logchunk 0 end-2] + } else { + if {$lastchar eq "\n"} { + set tail_lf 1 + set logchunk [string range $logchunk 0 end-1] + } elseif {$lastchar eq "\r"} { + #\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. + set tail_cr 1 + set logchunk [string range $logchunk 0 end-1] + } else { + #possibly a single line with no linefeed.. or has linefeeds only in the middle + } + } + + if {$ts_sent != 0} { + set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] + set time_info [::shellthread::iso8601 $ts_sent].$micros + #set time_info "${time_info}+$lag" + set lagfp "+[format %f $lag]" + } else { + #from pipe - no ts_sent/lag info available + set time_info "" + set lagfp "" + } + + set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway + set col0 [string repeat " " 9] + set col1 [string repeat " " 27] + set col2 [string repeat " " 11] + set col3 [string repeat " " 20] + #do not columnize the final data column or append to tail - or we could muck up the crlf integrity + + lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 + + #split on \n no matter the actual line-ending in use + #shouldn't matter as long as we don't add anything at the end of the line other than the raw data + #ie - don't quote or add spaces + set lines [split $logchunk \n] + + set i 1 + set outlines [list] + foreach ln $lines { + if {$i == 1} { + lappend outlines "$c0 $c1 $c2 $c3 $ln" + } else { + lappend outlines "$c0 $c1 $col2 $c3 $ln" + } + incr i + } + if {$tail_lf} { + set logchunk "[join $outlines \n]\n" + } elseif {$tail_crlf} { + set logchunk "[join $outlines \r\n]\r\n" + } elseif {$tail_cr} { + set logchunk "[join $outlines \r]\r" + } else { + #no trailing linefeed + set logchunk [join $outlines \n] + + } + + #set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" + } + + if {[string length $sysloghost_port]} { + _initsock + catch {puts -nonewline $sock $logchunk} + } + #todo - sockets etc? + if {[string length $logfile]} { + #todo - setting to maintain open filehandle and reduce io. + # possible settings for buffersize - and maybe logrotation, although this could be left to client + #for now - default to safe option of open/close each write despite the overhead. + set fd [open $logfile a] + chan configure $fd -translation auto -buffering $writebuffering + #whether line buffered or not - by now our logchunk includes newlines + puts -nonewline $fd $logchunk + close $fd + } + } + + # - withdraw just this client + proc finish {tidclient} { + variable client_ids + if {($tidclient in $clientids) && ([llength $clientids] == 1)} { + terminate $tidclient + } else { + set posn [lsearch $client_ids $tidclient] + set client_ids [lreplace $clientids $posn $posn] + } + } + + #allow any client to terminate + proc terminate {tidclient} { + variable sock + variable client_ids + if {$tidclient in $client_ids} { + catch {close $sock} + set client_ids [list] + return 1 + } else { + return 0 + } + } + + +} + + +namespace eval shellthread::manager { + variable workers [dict create] + variable worker_errors [list] + + variable free_threads [list] + #variable log_threads + + #new datastructure regarding workers and sourcetags required. + #one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. + #generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. + # + #As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins + #If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. + #If another thread want's to maintain joinability beyond the span provided by the starting client, + #it can join with both the primary tag and a tag it will actually use for logging. + #A thread can join the logger with any existingtag - not just the 'primary' + #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) + proc join_worker {existingtag sourcetaglist} { + set client_tid [thread::id] + #todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker + } + #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) + # This allows multiple threads to more easily write to the same named sourcetag if necessary + # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file + # + # todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. + # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target + # On the other hand socket targets such as UDP can happily be written to by multiple threads. + # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. + # but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. + # Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker + # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' + # probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. + proc new_worker {sourcetaglist {settingsdict {}}} { + variable workers + set ts_start [clock micros] + set tidclient [thread::id] + set sourcetag [lindex $sourcetaglist 0] ;#todo - use all + + if {[dict exists $workers $sourcetag]} { + set winfo [dict get $workers $sourcetag] + if {[thread::exists [dict get $winfo tid]]} { + #add our client-info to existing worker thread + dict lappend winfo list_client_tids $tidclient + dict set workers $sourcetag $winfo ;#writeback + return [dict get $winfo tid] + } + } + + #check if there is an existing unsubscribed thread first + variable free_threads + if {[llength $free_threads]} { + #todo - re-use from tail - as most likely to have been doing similar work?? review + + set free_threads [lassign $free_threads tidworker] + #todo - keep track of real ts_start of free threads... kill when too old + set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] + puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" + dict set workers $sourcetag $winfo + return $tidworker + } + + + #set ts_start [::shellthread::iso8601] + set tidworker [thread::create -preserved] + set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { + #set tclbase [file dirname [file dirname [info nameofexecutable]]] + #set tcllib $tclbase/lib + #if {$tcllib ni $::auto_path} { + # lappend ::auto_path $tcllib + #} + + set ::settingsinfo [dict create %sd%] + #if the executable running things is something like a tclkit, + # then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things + #The caller can tune the thread's package search by providing a settingsdict + if {![dict exists $::settingsinfo tcl_tm_list]} { + ::tcl::tm::add %mp% + } else { + tcl::tm::remove {*}[tcl::tm::list] + ::tcl::tm::add {*}[dict get $::settingsinfo tcl_tm_list] + } + if {![dict exists $::settingsinfo auto_path]} { + set ::auto_path [list %ap%] + } else { + set ::auto_path [dict get $::settingsinfo auto_path] + } + + package require Thread + package require shellthread + if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { + unset ::settingsinfo + set ::shellthread_init "ok" + } else { + unset ::settingsinfo + set ::shellthread_init "err $errmsg" + } + }] + + thread::send -async $tidworker $init_script + #thread::send $tidworker $init_script + set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] + dict set workers $sourcetag $winfo + return $tidworker + } + + proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { + variable workers + if {![dict exists $workers $tag_pipename]} { + error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" + } + set match_worker_tid [dict get $workers $tag_pipename tid] + if {$worker_tid ne $match_worker_tid} { + error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" + } + #buffering set during channel creation will be preserved on thread::transfer + thread::transfer $worker_tid $rchan + #start_pipe_read will vwait - so we have to send async + thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] + #client may start writing immediately - but presumably it will buffer in fifo2 + } + + proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { + variable workers + if {![dict exists $workers $tag_pipename]} { + error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" + } + set match_worker_tid [dict get $workers $tag_pipename tid] + if {$worker_tid ne $match_worker_tid} { + error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" + } + #buffering set during channel creation will be preserved on thread::transfer + thread::transfer $worker_tid $wchan + thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] + } + + proc write_log {source msg args} { + variable workers + set ts_micros_sent [clock micros] + set defaults [list -async 1 -level info] + set opts [dict merge $defaults $args] + + if {[dict exists $workers $source]} { + set tidworker [dict get $workers $source tid] + if {![thread::exists $tidworker]} { + set tidworker [new_worker $source] + } + } else { + #auto create with no requirement to call new_worker.. warn? + set tidworker [new_worker $source] + } + set client_tid [thread::id] + if {[dict get $opts -async]} { + thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] + } else { + thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] + } + } + proc report_worker_errors {errdict} { + variable workers + set reporting_tid [dict get $errdict worker_tid] + dict for {src srcinfo} $workers { + if {[dict get $srcinfo tid] eq $reporting_tid} { + dict set srcinfo errors [dict get $errdict errors] + dict set workers $src $srcinfo ;#writeback updated + break + } + } + } + + #aka leave_worker + #Note that the tags may be on separate workertids, or some tags may share workertids + proc unsubscribe {sourcetaglist} { + variable workers + #workers structure example: + #[list sourcetag1 [list tid list_client_tids ] ts_start ts_end_list {}] + variable free_threads + set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread + + set subscriberless_tags [list] + foreach source $sourcetaglist { + if {[dict exists $workers $source]} { + set list_client_tids [dict get $workers $source list_client_tids] + if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { + set list_client_tids [lreplace $list_client_tids $posn $posn] + dict set workers $source list_client_tids $list_client_tids + } + if {![llength $list_client_tids]} { + lappend subscriberless_tags $source + } + } + } + + #we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. + + set subscriberless_workers [list] + set shuttingdown_workers [list] + foreach deadtag $subscriberless_tags { + set workertid [dict get $workers $deadtag tid] + set worker_tags [get_worker_tagstate $workertid] + set subscriber_count 0 + set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed + foreach taginfo $worker_tags { + incr subscriber_count [llength [dict get $taginfo list_client_tids]] + incr kill_count [llength [dict get $taginfo ts_end_list]] + } + if {$subscriber_count == 0} { + lappend subscriberless_workers $workertid + } + if {$kill_count > 0} { + lappend shuttingdown_workers $workertid + } + } + + #if worker isn't shutting down - add it to free_threads list + foreach workertid $subscriberless_workers { + if {$workertid ni $shuttingdown_workers} { + if {$workertid ni $free_threads} { + lappend free_threads $workertid + } + } + } + + #todo + #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, + #if no more sourcetags - add worker to free_threads + } + proc get_worker_tagstate {workertid} { + variable workers + set taginfo_list [list] + dict for {source sourceinfo} $workers { + if {[dict get $sourceinfo tid] eq $workertid} { + lappend taginfo_list $sourceinfo + } + } + return $taginfo_list + } + + #instruction to shut-down the thread that has this source. + proc close_worker {source {timeout 2500}} { + variable workers + variable worker_errors + variable free_threads + set ts_now [clock micros] + #puts stderr "close_worker $source" + if {[dict exists $workers $source]} { + set tidworker [dict get $workers $source tid] + if {$tidworker in $freethreads} { + #make sure a thread that is being closed is removed from the free_threads list + set posn [lsearch $freethreads $tidworker] + set freethreads [lreplace $freethreads $posn $posn] + } + set mytid [thread::id] + set client_tids [dict get $workers $source list_client_tids] + if {[set posn [lsearch $client_tids $mytid]] >= 0} { + set client_tids [lreplace $client_tids $posn $posn] + #remove self from list of clients + dict set workers $source list_client_tids $client_tids + } + set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. + if {[llength $ts_end_list]} { + set last_end_ts [lindex $ts_end_list end] + if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { + lappend ts_end_list $ts_now + dict set workers $source ts_end_list $ts_end_list + } else { + #existing close in progress.. assume it will work + return + } + } + + if {[thread::exists $tidworker]} { + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" + set timeoutarr($source) 0 + after $timeout [list set timeoutarr($source) 2] + + thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] + thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) + + #thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { + # shellthread::worker::terminate %tidclient% + #}] timeoutarr($source) + + vwait timeoutarr($source) + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" + + thread::release $tidworker + #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" + if {[dict exists $workers $source errors]} { + set errlist [dict get $workers $source errors] + if {[llength $errlist]} { + lappend worker_errors [list $source [dict get $workers $source]] + } + } + dict unset workers $source + } else { + #thread may have been closed by call to close_worker with another source with same worker + #clear workers record for this source + #REVIEW - race condition for re-creation of source with new workerid? + #check that record is subscriberless to avoid this + if {[llength [dict get $workers $source list_client_tids]] == 0} { + dict unset workers $source + } + } + } + #puts stdout "close_worker $source - end" + } + + #worker errors only available for a source after close_worker called on that source + #It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, + # e.g if a thread + proc get_and_clear_errors {source} { + variable worker_errors + set source_errors [lsearch -all -inline -index 0 $worker_errors $source] + set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] + return $source_errors + } + + +} + + + + + + + + + + diff --git a/src/modules/punk/mix/templates/module/template_anyname-0.0.1.tm b/src/modules/punk/mix/templates/module/template_anyname-0.0.1.tm deleted file mode 100644 index a673d771..00000000 --- a/src/modules/punk/mix/templates/module/template_anyname-0.0.1.tm +++ /dev/null @@ -1,49 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2023 -# -# @@ Meta Begin -# Application %pkg% 999999.0a1.0 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -foreach base [tcl::tm::list] { - set nsprefix "";#in case sourced directly and not in any of the .tm paths - if {[string match -nocase ${base}* [info script]]} { - set nsprefix [string trimleft [join [lrange [file split [string range [info script] [string length $base]+1 end]] 0 end-1] ::]:: ::] - break - } -} -namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkgtail verparts]${nsprefix}$pkgtail { - #-------------------------------------- - #Do not put any 'package require' statements above this block. (globals nsprefix,pkgtail,verparts still set) - variable pkg "${::nsprefix}${::pkgtail}[unset ::nsprefix; unset ::pkgtail]" - variable version [join $::verparts -][unset ::verparts] - #-------------------------------------- - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - ## Requirements - ##e.g package require frobz - - - - - - - namespace eval [namespace current]::lib { - - } - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - ## Ready - uplevel #0 [list package provide $pkg $version] -} -return - diff --git a/src/modules/punk/mix/templates/module/modulename_buildversion.txt b/src/modules/punk/mix/templates/modules/modulename_buildversion.txt similarity index 100% rename from src/modules/punk/mix/templates/module/modulename_buildversion.txt rename to src/modules/punk/mix/templates/modules/modulename_buildversion.txt diff --git a/src/modules/punk/mix/templates/module/modulename_description.txt b/src/modules/punk/mix/templates/modules/modulename_description.txt similarity index 100% rename from src/modules/punk/mix/templates/module/modulename_description.txt rename to src/modules/punk/mix/templates/modules/modulename_description.txt diff --git a/src/modules/punk/mix/templates/module/template_anyname-0.0.2.tm b/src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm similarity index 100% rename from src/modules/punk/mix/templates/module/template_anyname-0.0.2.tm rename to src/modules/punk/mix/templates/modules/template_anyname-0.0.2.tm diff --git a/src/modules/punk/mix/templates/module/template_cli-0.0.1.tm b/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm similarity index 100% rename from src/modules/punk/mix/templates/module/template_cli-0.0.1.tm rename to src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm diff --git a/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm b/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm new file mode 100644 index 00000000..65547b40 --- /dev/null +++ b/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm @@ -0,0 +1,52 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) %year% +# +# @@ Meta Begin +# Application %pkg% 999999.0a1.0 +# Meta platform tcl +# Meta license %license% +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval %pkg% { + + + + +} + + + + + + + + + + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide %pkg% [namespace eval %pkg% { + variable pkg %pkg% + variable version + set version 999999.0a1.0 +}] +return \ No newline at end of file diff --git a/src/modules/punk/mix/templates/module/template_moduleexactversion-0.0.1.tm b/src/modules/punk/mix/templates/modules/template_moduleexactversion-0.0.1.tm similarity index 100% rename from src/modules/punk/mix/templates/module/template_moduleexactversion-0.0.1.tm rename to src/modules/punk/mix/templates/modules/template_moduleexactversion-0.0.1.tm diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 41e4f7bd..0f445fe5 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -767,6 +767,30 @@ namespace eval punk::repo { return $root_dict } + proc fossil_get_repository_file {{path {}}} { + if {$path eq {}} { set path [pwd] } + set fossilcmd [auto_execok fossil] + if {[llength $fossilcmd]} { + do_in_path $path { + set fossilinfo [::exec {*}$fossilcmd info] + } + set matching_lines [punk::repo::grep {repository:*} $fossilinfo] + if {![llength $matching_lines]} { + return "" + } + set trimmedline [string trim [lindex $matching_lines 0]] + set firstcolon [string first : $trimmedline] + set repofile_path [string trim [string range $trimmedline $firstcolon+1 end]] + if {![file exists $repofile_path]} { + puts stderr "Repository file pointed to by fossil configdb doesn't exist: $repofile_path" + return "" + } + return $repofile_path + } else { + puts stderr "fossil_get_repository_file: fossil command unavailable" + return "" + } + } proc fossil_get_repository_folder_for_project {projectname args} { set defaults [list -parentfolder \uFFFF -extrachoice \uFFFF] @@ -1040,7 +1064,7 @@ namespace eval punk::repo { do_in_path $path { set info [::exec {*}$fossilcmd remote ls] } - return [string trim $v] + return [string trim $info] } else { return Unknown } diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index 5c9c322d..a65e1f7a 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -1141,6 +1141,7 @@ namespace eval punkcheck { set opt_antiglob_file_core [dict get $opts -antiglob_file_core] if {$opt_antiglob_file_core eq "\uFFFF"} { set opt_antiglob_file_core [default_antiglob_file_core] + dict set opts -antiglob_file_core $opt_antiglob_file_core } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_file [dict get $opts -antiglob_file] @@ -1148,6 +1149,7 @@ namespace eval punkcheck { set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { set opt_antiglob_dir_core [default_antiglob_dir_core] + dict set opts -antiglob_dir_core $opt_antiglob_dir_core } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir [dict get $opts -antiglob_dir] @@ -1173,6 +1175,7 @@ namespace eval punkcheck { } else { set opt_source_checksum 0 } + dict set opts -source_checksum $opt_source_checksum } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_punkcheck_folder [dict get $opts -punkcheck_folder] @@ -1218,13 +1221,15 @@ namespace eval punkcheck { if {$CALLDEPTH == 0} { set punkcheck_eventid "" if {$punkcheck_folder ne ""} { - set config [dict create\ - -glob $fileglob\ - -antiglob_file_core $opt_antiglob_file_core\ - -antiglob_file $opt_antiglob_file\ - -antiglob_dir_core $opt_antiglob_dir_core\ - -antiglob_dir $opt_antiglob_dir\ - ] + set config $opts + dict unset config -call-depth-internal + dict unset config -max_depth + dict unset config -subdirlist + dict for {k v} $config { + if {$v eq "\uFFFF"} { + dict unset config $k + } + } lassign [punkcheck::start_installer_event $punkcheck_file $opt_installer $srcdir $tgtdir $config] _eventid punkcheck_eventid _recordset punkcheck_records } } else { @@ -1259,11 +1264,23 @@ namespace eval punkcheck { } - #normalize? review/test + set relative_target_dir [lib::path_relative $tgtdir $current_target_dir] + if {$relative_target_dir eq "."} { + set relative_target_dir "" + } + set relative_source_dir [lib::path_relative $srcdir $current_source_dir] + if {$relative_source_dir eq "."} { + set relative_source_dir "" + } + set target_relative_to_punkcheck_dir [lib::path_relative $punkcheck_folder $current_target_dir] + if {$target_relative_to_punkcheck_dir eq "."} { + set target_relative_to_punkcheck_dir "" + } foreach unpub $opt_unpublish_paths { - if {[globmatchpath $unpub $current_source_dir]} { + #puts "testing folder - globmatchpath $unpub $relative_source_dir" + if {[globmatchpath $unpub $relative_source_dir]} { lappend unpublish_paths_matched $current_source_dir - return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records] + return [list files_copied {} files_skipped {} sources_unchanged {} punkcheck_records $punkcheck_records unpublish_paths_matched $unpublish_paths_matched] } } @@ -1326,9 +1343,13 @@ namespace eval punkcheck { #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { + set relative_target_path [file join $relative_target_dir $m] + set relative_source_path [file join $relative_source_dir $m] + set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_unpublished 0 foreach unpub $opt_unpublish_paths { - if {[globmatchpath $unpub $current_source_dir/$m]} { + #puts "testing file - globmatchpath $unpub vs $relative_source_path" + if {[globmatchpath $unpub $relative_source_path]} { lappend unpublish_paths_matched $current_source_dir set is_unpublished 1 break @@ -1342,20 +1363,20 @@ namespace eval punkcheck { set seconds [expr {$ts_start / 1000000}] set ts_start_iso [clock format $seconds -format "%Y-%m-%dT%H:%M:%S"] - set relative_target_path [lib::path_relative $punkcheck_folder $current_target_dir/$m] - #puts stdout " rel_target: $relative_target_path" + + #puts stdout " rel_target: $punkcheck_target_relpath" - set fetch_filerec_result [punkcheck::recordlist::get_file_record $relative_target_path $punkcheck_records] + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] if {$existing_filerec_posn == -1} { - puts stdout "NO existing record for $relative_target_path" + puts stdout "NO existing record for $punkcheck_target_relpath" set has_filerec 0 - set new_filerec [dict create tag FILEINFO -targets $relative_target_path] + set new_filerec [dict create tag FILEINFO -targets $punkcheck_target_relpath] set filerec $new_filerec } else { set has_filerec 1 - #puts stdout " TDL existing FILEINFO record for $relative_target_path" + #puts stdout " TDL existing FILEINFO record for $punkcheck_target_relpath" #puts stdout " $existing_install_record" set filerec [dict get $fetch_filerec_result record] } @@ -1478,7 +1499,8 @@ namespace eval punkcheck { file mkdir $current_target_dir/$d } - set sub_result [punkcheck::install $srcdir $tgtdir\ + + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ -subdirlist [list {*}$subdirlist $d]\ -glob $fileglob\ @@ -1493,6 +1515,15 @@ namespace eval punkcheck { -punkcheck_records $punkcheck_records\ -installer $opt_installer\ ] + set sub_opts [list\ + -call-depth-internal [expr {$CALLDEPTH + 1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_folder $punkcheck_folder\ + -punkcheck_eventid $punkcheck_eventid\ + -punkcheck_records $punkcheck_records\ + ] + set sub_opts [dict merge $opts $sub_opts] + set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] lappend files_copied {*}[dict get $sub_result files_copied] lappend files_skipped {*}[dict get $sub_result files_skipped] @@ -1504,10 +1535,11 @@ namespace eval punkcheck { if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { - if {[llength $files_copied]} { + if {[llength $files_copied] || [llength $files_skipped]} { puts stdout ">>>>>>>>>>>>>>>>>>>" set saveresult [punkcheck::save_records_to_file $punkcheck_records $punkcheck_file] puts stdout "[dict get $saveresult recordcount] records saved as [dict get $saveresult linecount] lines to $punkcheck_file" + puts stdout "copied: [llength $files_copied] skipped: [llength $files_skipped]" puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index e0e31cfc..6ecd6e45 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -75,13 +75,18 @@ package require Thread #These are strong dependencies # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list - -package forget shellfilter -package require shellfilter -package forget shellrun -package require shellrun -package forget punk -package require punk +set required [list\ + shellfilter\ + shellrun\ + punk\ + ] + +catch { + foreach pkg $required { + package forget $pkg + package require $pkg + } +} #restore module paths @@ -95,6 +100,10 @@ foreach p $original_tm_list { } #------------------------------------------------------------------------------ +foreach pkg $required { + package require $pkg +} + package require punk::repl repl::start stdin diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index 1769667b..7080d735 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -2,3 +2,5 @@ #if runtime has no entry - it will only match a .vfs folder with a matching filename e.g runtime1.exe runtime1.vfs tclkit86bi.exe punk86.vfs tclkit87a5bawt.exe punk86.vfs +#tclkit86bi.exe vfs_windows/punk86win.vfs +