Tcl Source Code

Check-in [52fd51a4df]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:[b9d0434667] Prefer the gzip encoding for transfers. It's less efficient, but it is far more interoperable and that's a more important metric.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 52fd51a4df574326ad083bda1744231ba53ef122
User & Date: dkf 2015-05-14 08:05:37
Context
2015-05-14
08:23
[6a71dbe6ec] Ensure that compression errors log correctly. check-in: b61e62776b user: dkf tags: trunk
08:05
[b9d0434667] Prefer the gzip encoding for transfers. It's less efficient, but it is far more interop... check-in: 52fd51a4df user: dkf tags: trunk
2015-04-30
15:31
test portability check-in: 019ec0ba40 user: dgp tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/http/http.tcl.

735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $sock "$key: $value"
	    }
	}
        if {!$accept_encoding_seen && ![info exists state(-handler)]} {
	    puts $sock "Accept-Encoding: deflate,gzip,compress"
        }
	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






|







735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $sock "$key: $value"
	    }
	}
        if {!$accept_encoding_seen && ![info exists state(-handler)]} {
	    puts $sock "Accept-Encoding: gzip,deflate,compress"
        }
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel. If we cannot seek, the
	    # surrounding catch will trap us

	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end

Changes to tests/http11.test.

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
...
443
444
445
446
447
448
449
450

451
452
453
454
455
456
457
...
477
478
479
480
481
482
483





















484
485
486
487
488
489
490
...
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
    set chk [format %x [zlib crc32 $data]]
    if {$crc ne $chk} {
        return  "crc32 mismatch: $crc ne $chk"
    }
    return "ok"
}

makeFile "<html><head><title>test</title></head>\
<body><p>this is a test</p>\n\
[string repeat {<p>This is a tcl test file.</p>} 4192]\n\
</body></html>" testdoc.html

# -------------------------------------------------------------------------

test http11-1.0 "normal request for document " -setup {
    variable httpd [create_httpd]
} -body {
    set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
    http::wait $tok
................................................................................
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}

test http11-2.10 "-channel,deflate,keepalive" -setup {
    variable httpd [create_httpd]
    set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
    set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
                 -timeout 5000 -channel $chan -keepalive 1]

    http::wait $tok
    seek $chan 0
    set data [read $chan]
    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
        [meta $tok connection] [meta $tok content-encoding]\
        [meta $tok transfer-encoding]\
        [expr {[file size testdoc.html]-[file size testfile.tmp]}]
................................................................................
        [meta $tok transfer-encoding]
} -cleanup {
    http::cleanup $tok
    close $chan
    removeFile testfile.tmp
    halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}






















# -------------------------------------------------------------------------
#
# The following tests for the -handler option will require changes in
# the future. At the moment we cannot handler chunked data with this
# option. Therefore we currently force HTTP/1.0 protocol version.
#
................................................................................
        query-length [meta $tok x-query-length]
} -cleanup {
    http::cleanup $tok
    close $chan
    removeFile testfile.tmp
    halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}

# -------------------------------------------------------------------------

foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
    if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
unset -nocomplain httpd_port httpd p

::tcltest::cleanupTests






<
<
|
<
|







 







|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|









66
67
68
69
70
71
72


73

74
75
76
77
78
79
80
81
...
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
    set chk [format %x [zlib crc32 $data]]
    if {$crc ne $chk} {
        return  "crc32 mismatch: $crc ne $chk"
    }
    return "ok"
}



makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html

 
# -------------------------------------------------------------------------

test http11-1.0 "normal request for document " -setup {
    variable httpd [create_httpd]
} -body {
    set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
    http::wait $tok
................................................................................
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}

test http11-2.10 "-channel,deflate,keepalive" -setup {
    variable httpd [create_httpd]
    set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
    set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
                 -timeout 5000 -channel $chan -keepalive 1 \
		 -headers {accept-encoding deflate}]
    http::wait $tok
    seek $chan 0
    set data [read $chan]
    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
        [meta $tok connection] [meta $tok content-encoding]\
        [meta $tok transfer-encoding]\
        [expr {[file size testdoc.html]-[file size testfile.tmp]}]
................................................................................
        [meta $tok transfer-encoding]
} -cleanup {
    http::cleanup $tok
    close $chan
    removeFile testfile.tmp
    halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}

test http11-2.12 "-channel,negotiate,keepalive" -setup {
    variable httpd [create_httpd]
    set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
    set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
                 -timeout 5000 -channel $chan -keepalive 1]
    http::wait $tok
    seek $chan 0
    set data [read $chan]
    list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
        [meta $tok connection] [meta $tok content-encoding]\
        [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\
        [expr {[file size testdoc.html]-[file size testfile.tmp]}]
} -cleanup {
    http::cleanup $tok
    close $chan
    removeFile testfile.tmp
    halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}


# -------------------------------------------------------------------------
#
# The following tests for the -handler option will require changes in
# the future. At the moment we cannot handler chunked data with this
# option. Therefore we currently force HTTP/1.0 protocol version.
#
................................................................................
        query-length [meta $tok x-query-length]
} -cleanup {
    http::cleanup $tok
    close $chan
    removeFile testfile.tmp
    halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
 
# -------------------------------------------------------------------------

foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
    if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
unset -nocomplain httpd_port httpd p

::tcltest::cleanupTests

Changes to tests/httpd11.tcl.

154
155
156
157
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
...
185
186
187
188
189
190
191

192
193
194
195
196
197
198
            set data [read $f]
            close $f
            set code "200 OK"
            set close [expr {[dict get? $meta connection] eq "close"}]
        }
        
        if {$protocol eq "HTTP/1.1"} {
            if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
                set encoding deflate
            } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
                set encoding gzip
            } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
                set encoding compress
            }

            set transfer chunked
        } else {
            set close 1
        }
        
        foreach pair [split $query &] {
            if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
................................................................................
        Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
        if {$req eq "POST"} {
            Puts $chan [format "x-query-length: %d" [string length $query]]
        }
        if {$close} {
            Puts $chan "connection: close"
        }

        if {$encoding eq "identity"} {
            Puts $chan "content-length: [string length $data]"
        } else {
            Puts $chan "content-encoding: $encoding"
        }
        if {$transfer eq "chunked"} {
            Puts $chan "transfer-encoding: chunked"






|
|
|
|
|
<
|
>







 







>







154
155
156
157
158
159
160
161
162
163
164
165

166
167
168
169
170
171
172
173
174
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
            set data [read $f]
            close $f
            set code "200 OK"
            set close [expr {[dict get? $meta connection] eq "close"}]
        }
        
        if {$protocol eq "HTTP/1.1"} {
	    foreach enc [split [dict get? $meta accept-encoding] ,] {
		set enc [string trim $enc]
		if {$enc in {deflate gzip compress}} {
		    set encoding $enc
		    break

		}
	    }
            set transfer chunked
        } else {
            set close 1
        }
        
        foreach pair [split $query &] {
            if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
................................................................................
        Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
        if {$req eq "POST"} {
            Puts $chan [format "x-query-length: %d" [string length $query]]
        }
        if {$close} {
            Puts $chan "connection: close"
        }
	Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
        if {$encoding eq "identity"} {
            Puts $chan "content-length: [string length $data]"
        } else {
            Puts $chan "content-encoding: $encoding"
        }
        if {$transfer eq "chunked"} {
            Puts $chan "transfer-encoding: chunked"