diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/http/http.tcl | 27 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 41 |
2 files changed, 63 insertions, 5 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl index 88f66eb..fb49954 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1746,6 +1746,9 @@ proc http::OpenSocket {token DoLater} { } fconfigure $sock -translation {auto crlf} \ -buffersize $state(-blocksize) + if {[package vsatisfies [package provide Tcl] 9.0-]} { + fconfigure $sock -profile replace \ + } ##Log socket opened, DONE fconfigure - token $token } @@ -2164,6 +2167,9 @@ proc http::Connected {token proto phost srvurl} { 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 replace \ + } # The following is disallowed in safe interpreters, but the socket is # already in non-blocking mode in that case. @@ -2554,6 +2560,9 @@ proc http::ReceiveResponse {token} { 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 replace \ + } Log ^D$tk begin receiving response - token $token coroutine ${token}--EventCoroutine http::Event $sock $token @@ -4545,7 +4554,11 @@ proc http::Eot {token {reason {}}} { set enc [CharsetToEncoding $state(charset)] if {$enc ne "binary"} { - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile replace $enc $state(body)] + } else { + set state(body) [encoding convertfrom $enc $state(body)] + } } # Translate text line endings. @@ -4628,7 +4641,11 @@ proc http::GuessType {token} { if {$enc eq "binary"} { return 0 } - set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)] + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set state(body) [encoding convertfrom -profile replace $enc $state(body)] + } else { + set state(body) [encoding convertfrom -profile replace $enc $state(body)] + } set state(body) [string map {\r\n \n \r \n} $state(body)] set state(type) application/xml set state(binary) 0 @@ -4709,7 +4726,11 @@ proc http::quoteString {string} { # a pre-computed map and [string map] to do the conversion (much faster # than [regsub]/[subst]). [Bug 1020491] - set string [encoding convertto -profile tcl8 $http(-urlencoding) $string] + if {[package vsatisfies [package provide Tcl] 9.0-]} { + set string [encoding convertto -profile replace $http(-urlencoding) $string] + } else { + set string [encoding convertto $http(-urlencoding) $string] + } return [string map $formMap $string] } diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 1ba5d9f..12791da 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1134,6 +1134,39 @@ proc tcltest::SafeFetch {n1 n2 op} { } } + +# tcltest::Asciify -- +# +# Transforms the passed string to contain only printable ascii characters. +# Useful for printing to terminals. Non-printables are mapped to +# \x, \u or \U sequences. +# +# Arguments: +# s - string to transform +# +# Results: +# The transformed strings +# +# Side effects: +# None. + +proc tcltest::Asciify {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print +} + # tcltest::ConstraintInitializer -- # # Get or set a script that when evaluated in the tcltest namespace @@ -2221,9 +2254,13 @@ proc tcltest::test {name description args} { if {$scriptCompare} { puts [outputChannel] "---- Error testing result: $scriptMatch" } else { - puts [outputChannel] "---- Result was:\n$actualAnswer" + if {[catch { + puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]" + } errMsg]} { + puts [outputChannel] "\n---- Result was:\n<error printing result: $errMsg>" + } puts [outputChannel] "---- Result should have been\ - ($match matching):\n$result" + ($match matching):\n[Asciify $result]" } } if {$errorCodeFailure} { |