Tcl Source Code

Check-in [7fcd7262f6]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:Started to add support for tcloo into tcltest package. First set of http test using TIP 452.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-452
Files: files | file ages | folders
SHA1:7fcd7262f62eb3d5a185a4abf5e62200762f16e7
User & Date: gerald 2017-06-16 15:15:46
Context
2017-06-16
16:28
Added empty failing test for each unit that should be tested. NOTE -- some units will have multiple... check-in: a57bb47530 user: gerald tags: tip-452
15:15
Started to add support for tcloo into tcltest package. First set of http test using TIP 452. check-in: 7fcd7262f6 user: gerald tags: tip-452
2017-06-10
17:06
1) Added namespace exports to tcltest namespace for new features 2) Rolled minor revision number of ... check-in: 9c86f726c0 user: gerald tags: tip-452
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/tcltest/tcltest.tcl.

4132
4133
4134
4135
4136
4137
4138



























































































































































































4139
4140
4141
4142
4143
4144
4145
###########################################################################
proc ::tcltest::SeamDeactivate {procName seamName} {
    variable SeamData

    unset -nocomplain SeamData($procName,$seamName,useBody)
    return 1
}




























































































































































































##
## End TIP 452
##


# Initialize the constraints and set up command line arguments







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







4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
###########################################################################
proc ::tcltest::SeamDeactivate {procName seamName} {
    variable SeamData

    unset -nocomplain SeamData($procName,$seamName,useBody)
    return 1
}

##
## Add in the TclOO support
##

oo::class create ::tcltest::object {

  # An independant constructor that tcltest can control
  constructor args {
    my variable tcltest
    set tcltest(mixinmap) {}
    my tcltest_configure {*}$args
  }

  destructor {
    my variable tcltest
    if {[info exists tcltest(destructor)]} {
      eval $tcltest(destructor)
    } else {
      next
    }
  }

  method tcltest_destructor body {
    my variable tcltest
    set tcltest(destructor) $body
  }

  # A means of controlling the tcltest framework class
  # Note the method names are designed to minimize conflict
  # with existing classes
  method tcltest_configure args {
    foreach {key value} $args {
      switch [string trimleft $key -] {
        class {
          set tcltest(class) $value
          my tcltest_morph $value
        }
        eval {
          eval $value
        }
        destructor {
          my tcltest_destructor $value
        }
      }
    }
  }

  method tcltest_set args {
    my variable tcltest
    array set tcltest $args
  }

  method tcltest_morph classname {
    my variable tcltest
    if {[info commands ::tcltest::hybrid::$classname] eq {}} {
      oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
    }
    set tcltest(class) $classname
    ::oo::objdefine [self] class ::tcltest::hybrid::$classname
    if {[info exists tcltest(mixinmap)]} {
      my Tcltest_mixin_apply $tcltest(mixinmap)
    }
  }

  # A method to allow tcltest to invoke code internally to
  # objects. Including access to private methods and variables
  method tcltest_eval script {
    eval $script
  }

  method Tcltest_mixin_apply {map} {
    set mixlist {}
    foreach {s c} $map {
      if {$c eq {}} continue
      lappend mixlist $c
    }
    ::oo::objdefine [self] mixin {*}$mixlist
  }

  # A formalized slot-based mechanism for managing mixins. Because we
  # break the space up into slots, individual aspects of behavior
  # can be added, removed, and combined with other mixins.
  # We use a dict internally for storage to allow the order in which mixins
  # were applied to be preserved. Not the difference between:
  # tcltest_mixin map FOO {}
  # and
  # tcltest_mixin unmap FOO
  #
  # A blank mapping will removed the effect, but preserve FOO's place in line
  # Unmap removes the concept completely.
  #
  method tcltest_mixin {command args} {
    my variable tcltest
    switch $command {
      dump {
        return $tcltest(mixinmap)
      }
      map {
        if {[llength $args]!=2} {
          error "Usage: [self method] map STUB CLASS"
        }
        lassign $args stub class
        # Placed here as a safety in case the before or after did not actually exist
        # And it's a handy place to make the call even if we didn't use before/after
        dict set tcltest(mixinmap) $stub $class
        # Build the list of classes to mixin, in the order proscribed by the dict
        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      replace {
        # Allows users to specify the order of mixins
        # Note we always include ::tcltest::object
        set tcltest(mixinmap) $args
        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      unmap {
        if {[llength $args]!=1} {
          error "Usage: mixinmap unmap STUB"
        }
        lassign $args stub
        if {[dict exists $tcltest(mixinmap) $stub]} {
          dict unset tcltest(mixinmap) $stub
        }
        my Tcltest_mixin_apply $tcltest(mixinmap)
      }
      default {
        error "Valid commands are: dump, map, replace, unmap"
      }
    }
  }
}

##
## Define the "Static" methods on the ::tcltest::object
##
oo::objdefine ::tcltest::object {
  method hijack object {
    set classname [info object class $object]
    if {[info commands ::tcltest::hybrid::$classname] eq {}} {
      oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
    }
    ::oo::objdefine $object class ::tcltest::hybrid::$classname
    $object tcltest_set class $classname
  }
}

##
## Add in the "easy to use" command
##
namespace eval ::tcltest:: {
    array set ::tcltest::SavedObjectDefinitions {
        constructor {}
        destructor  {}
    }

    proc  testObject {name description class args} {
        if {([llength $args] % 2) != 0 } {
            return -code error {Unpaired options and values.}
        }
        array set optionArr {
            -objectVar cut
            -arguments {}
            -stubs {}
        }
        array set optionArr $args

        set objectVarName $optionArr(-objectVar)
        unset -nocomplain optionArr(-objectVar)
        upvar 1 $objectVarName cut

        set consList [info class constructor $class]
        if {![info exists optionArr(-constructor)]} {
            set optionArr(-constructor) [lindex $consList 1]
        }
        set consScript {}
        if {llength [lindex $consList 0]]} {
            append consScript \
                [format {lassign {%s} %s} $optionArr(-arguments) [lindex $consList 0]] \
                "\n"
        }
        append consScript $optionArr(-constructor)

        if {![info exists optionArr(-destructor)]} {
            set optionArr(-destructor) [info class destructor $class]
        }
    }
}

##
## End TIP 452
##


# Initialize the constraints and set up command line arguments

Changes to tests/http-tip-452.test.

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
..
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84



85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122


123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183







184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200



201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233

234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324



325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373

374

375


376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411


412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
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
510
511
512
513
514
515
516
517
518
519



520

521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547

548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624


625
626
627
628
629



630
631
632

633


634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2017 by Gerald W. Lester.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2.5
namespace import -force ::tcltest::*

if {[catch {package require http 2} version]} {
    if {[info exists http2]} {
	catch {puts "Cannot load http 2.* package"}
	return
    } else {
	catch {puts "Running http 2.* tests in slave interp"}
................................................................................
    puts stderr $errorInfo
}

set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

 
test http-1.1 {http::config} {
    http::config -useragent UserAgent
    http::config
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
test http-1.2 {http::config} {
    http::config -proxyfilter
} http::ProxyRequired
test http-1.3 {http::config} {
    catch {http::config -junk}
} 1
test http-1.4 {http::config} {
    set savedconf [http::config]
    http::config -proxyhost nowhere.come -proxyport 8080 \
	-proxyfilter myFilter -useragent "Tcl Test Suite" \
	-urlencoding iso8859-1
    set x [http::config]
    http::config {*}$savedconf
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
test http-1.5 {http::config} -returnCodes error -body {
    http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
test http-1.6 {http::config} -setup {
    set oldenc [http::config -urlencoding]
} -body {
    set enc [list [http::config -urlencoding]]
    http::config -urlencoding iso8859-1
    lappend enc [http::config -urlencoding]
} -cleanup {
    http::config -urlencoding $oldenc
} -result {utf-8 iso8859-1}

test http-2.1 {http::reset} {
    catch {http::reset http#1}
} 0




test http-3.1 {http::geturl} -returnCodes error -body {
    http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
    http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //[info hostname]:$port
set badurl //[info hostname]:[expr $port+1]
test http-3.3 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set xmlurl //[info hostname]:$port/xml
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set authorityurl //[info hostname]:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
proc selfproxy {host} {
    global port
    return [list [info hostname] $port]


}
test http-3.5 {http::geturl} -body {
    http::config -proxyfilter selfproxy
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::config -proxyfilter http::ProxyRequired
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http:$url</h2>
</body></html>"
test http-3.6 {http::geturl} -body {
    http::config -proxyfilter bogus
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::config -proxyfilter http::ProxyRequired
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.7 {http::geturl} -body {
    set token [http::geturl $url -headers {Pragma no-cache}]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.8 {http::geturl} -body {
    set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<dt>Foo<dd>Bar
</dl>
</body></html>"
test http-3.9 {http::geturl} -body {
    set token [http::geturl $url -validate 1]
    http::code $token
} -cleanup {
    http::cleanup $token
} -result "HTTP/1.0 200 OK"
test http-3.10 {http::geturl queryprogress} -setup {
    set query foo=bar
    set sep ""
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &







    }
} -body {
    proc postProgress {token x y} {
	global postProgress
	lappend postProgress $y
    }
    set postProgress {}
    set t [http::geturl $posturl -keepalive 0 -query $query \
	    -queryprogress postProgress -queryblocksize 16384]
    http::wait $t
    list [http::status $t] [string length $query] $postProgress [http::data $t]
} -cleanup {
    http::cleanup $t
} -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
test http-3.11 {http::geturl querychannel with -command} -setup {
    set query foo=bar
    set sep ""



    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    set file [makeFile $query outdata]
} -body {
    set fp [open $file]
    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    set postResult [list ]
    set t [http::geturl $posturl -querychannel $fp]
    http::wait $t
    set testRes [list [http::status $t] [string length $query] [http::data $t]]
    # Now do async
    http::cleanup $t
    close $fp
    set fp [open $file]
    set t [http::geturl $posturl -querychannel $fp -command asyncCB]
    set postResult [list PostStart]
    http::wait $t
    close $fp
    lappend testRes [http::status $t] $postResult
} -cleanup {
    removeFile outdata
    http::cleanup $t
} -result {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
# On Linux platforms when the client and server are on the same host, the
# client is unable to read the server's response one it hits the write error.

# The status is "eof".
# On Windows, the http::wait procedure gets a "connection reset by peer" error
# while reading the reply.
test http-3.12 {http::geturl querychannel with aborted request} -setup {
    set query foo=bar
    set sep ""
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    set file [makeFile $query outdata]
} -constraints {nonPortable} -body {
    set fp [open $file]
    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    proc postProgress {token x y} {
	global postProgress
	lappend postProgress $y
    }
    set postProgress {}
    # Now do async
    set postResult [list PostStart]
    if {[catch {
	set t [http::geturl $badposturl -querychannel $fp -command asyncCB \
		-queryprogress postProgress]
	http::wait $t
	upvar #0 $t state
    } err]} {
	puts $::errorInfo
	error $err
    }
    list [http::status $t] [http::code $t]
} -cleanup {
    removeFile outdata
    http::cleanup $t
} -result {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {
    set chanCount [llength [file channels]]
    for {set i 0} {$i < 3} {incr i} {
	catch {http::geturl $badurl -timeout 5000}
    }
    # No extra channels should be taken
    expr {[llength [file channels]] == $chanCount}
} 1
test http-3.14 "http::geturl $fullurl" -body {
    set token [http::geturl $fullurl -validate 1]
    http::code $token
} -cleanup {
    http::cleanup $token
} -result "HTTP/1.0 200 OK"
test http-3.15 {http::geturl parse failures} -body {
    http::geturl "{invalid}:url"
} -returnCodes error -result {Unsupported URL: {invalid}:url}
test http-3.16 {http::geturl parse failures} -body {
    http::geturl http:relative/url
} -returnCodes error -result {Unsupported URL: http:relative/url}
test http-3.17 {http::geturl parse failures} -body {
    http::geturl /absolute/url
} -returnCodes error -result {Missing host part: /absolute/url}
test http-3.18 {http::geturl parse failures} -body {
    http::geturl http://somewhere:123456789/
} -returnCodes error -result {Invalid port number: 123456789}
test http-3.19 {http::geturl parse failures} -body {
    http::geturl http://{user}@somewhere
} -returnCodes error -result {Illegal characters in URL user}
test http-3.20 {http::geturl parse failures} -body {
    http::geturl http://%user@somewhere
} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
test http-3.21 {http::geturl parse failures} -body {
    http::geturl http://somewhere/{path}
} -returnCodes error -result {Illegal characters in URL path}
test http-3.22 {http::geturl parse failures} -body {
    http::geturl http://somewhere/%path
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
test http-3.23 {http::geturl parse failures} -body {
    http::geturl http://somewhere/path?{query}?
} -returnCodes error -result {Illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
    http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::meta} -setup {
    unset -nocomplain m token
} -body {
    set token [http::geturl $url -timeout 2000]
    array set m [http::meta $token]
    lsort [array names m]



} -cleanup {
    http::cleanup $token
    unset -nocomplain m token
} -result {Content-Length Content-Type Date}
test http-3.26 {http::meta} -setup {
    unset -nocomplain m token
} -body {
    set token [http::geturl $url -headers {X-Check 1} -timeout 2000]
    array set m [http::meta $token]
    lsort [array names m]
} -cleanup {
    http::cleanup $token
    unset -nocomplain m token
} -result {Content-Length Content-Type Date X-Check}
test http-3.27 {http::geturl: -headers override -type} -body {
    set token [http::geturl $url/headers -type "text/plain" -query dummy \
	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.28 {http::geturl: -headers override -type default} -body {
    set token [http::geturl $url/headers -query dummy \
	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.29 {http::geturl IPv6 address} -body {
    # We only want to see if the URL gets parsed correctly. This is
    # the case if http::geturl succeeds or returns a socket related
    # error. If the parsing is wrong, we'll get a parse error.
    # It'd be better to separate the URL parser from http::geturl, so
    # that it can be tested without also trying to make a connection.
    set error [catch {http::geturl $ipv6url -validate 1} token]
    if {$error && [string match "couldn't open socket: *" $token]} {
            set error 0

    }

    set error


} -cleanup {
    catch { http::cleanup $token }
} -result 0
test http-3.30 {http::geturl query without path} -body {
    set token [http::geturl $authorityurl?var=val]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200
test http-3.31 {http::geturl fragment without path} -body {
    set token [http::geturl "$authorityurl#fragment42"]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200
# Bug c11a51c482
test http-3.32 {http::geturl: -headers override -accept default} -body {
    set token [http::geturl $url/headers -query dummy \
	    -headers [list "Accept" "text/plain,application/tcl-test-value"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Accept text/plain,application/tcl-test-value
Accept-Encoding .*
Content-Type application/x-www-form-urlencoded
Content-Length 5}
# Bug 838e99a76d
test http-3.33 {http::geturl application/xml is text} -body {
    set token [http::geturl "$xmlurl"]
    scan [http::data $token] "<%\[^>]>%c<%\[^>]>"
} -cleanup {
    catch { http::cleanup $token }
} -result {test 4660 /test}



test http-4.1 {http::Event} -body {
    set token [http::geturl $url -keepalive 0]
    upvar #0 $token data
    array set meta $data(meta)
    expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
    http::cleanup $token
} -result 1
test http-4.2 {http::Event} -body {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    string compare $data(type) [string trim $meta(Content-Type)]
} -cleanup {
    http::cleanup $token
} -result 0
test http-4.3 {http::Event} -body {
    set token [http::geturl $url]
    http::code $token
} -cleanup {
    http::cleanup $token
} -result {HTTP/1.0 200 Data follows}
test http-4.4 {http::Event} -setup {
    set testfile [makeFile "" testfile]
} -body {
    set out [open $testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    set in [open $testfile]
    set x [read $in]
} -cleanup {
    catch {close $in}
    catch {close $out}
    removeFile $testfile
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-4.5 {http::Event} -setup {
    set testfile [makeFile "" testfile]
} -body {
    set out [open $testfile w]
    fconfigure $out -translation lf
    set token [http::geturl $url -channel $out]
    close $out
    upvar #0 $token data
    expr {$data(currentsize) == $data(totalsize)}
} -cleanup {
    removeFile $testfile
    http::cleanup $token
} -result 1
test http-4.6 {http::Event} -setup {
    set testfile [makeFile "" testfile]
} -body {
    set out [open $testfile w]
    set token [http::geturl $binurl -channel $out]
    close $out
    set in [open $testfile]
    fconfigure $in -translation binary
    read $in
} -cleanup {
    catch {close $in}
    catch {close $out}
    removeFile $testfile
    http::cleanup $token
} -result "$bindata[string trimleft $binurl /]"
proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"







    }
    set progress [list $total $current]
}
test http-4.6.1 {http::Event} knownBug {
    set token [http::geturl $url -blocksize 50 -progress myProgress]
    return $progress
} {111 111}
test http-4.7 {http::Event} -body {
    set token [http::geturl $url -keepalive 0 -progress myProgress]
    return $progress
} -cleanup {
    http::cleanup $token
} -result {111 111}
test http-4.8 {http::Event} -body {
    set token [http::geturl $url]
    http::status $token
} -cleanup {
    http::cleanup $token
} -result {ok}
test http-4.9 {http::Event} -body {
    set token [http::geturl $url -progress myProgress]
    http::code $token
} -cleanup {
    http::cleanup $token
} -result {HTTP/1.0 200 Data follows}
test http-4.10 {http::Event} -body {
    set token [http::geturl $url -progress myProgress]
    http::size $token
} -cleanup {
    http::cleanup $token
} -result {111}
# Timeout cases
#	Short timeout to working server (the test server). This lets us try a
#	reset during the connection.
test http-4.11 {http::Event} -body {
    set token [http::geturl $url -timeout 1 -keepalive 0 -command \#]



    http::reset $token

    http::status $token
} -cleanup {
    http::cleanup $token
} -result {reset}
#	Longer timeout with reset.
test http-4.12 {http::Event} -body {
    set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#]
    http::reset $token
    http::status $token
} -cleanup {
    http::cleanup $token
} -result {reset}
#	Medium timeout to working server that waits even longer. The timeout
#	hits while waiting for a reply.
test http-4.13 {http::Event} -body {
    set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#]
    http::wait $token
    http::status $token
} -cleanup {
    http::cleanup $token
} -result {timeout}
#	Longer timeout to good host, bad port, gets an error after the
#	connection "completes" but the socket is bad.
test http-4.14 {http::Event} -body {
    set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#]
    if {$token eq ""} {
	error "bogus return from http::geturl"

    }
    http::wait $token
    lindex [http::error $token] 0
} -cleanup {
    catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
    # This test may fail if you use a proxy server. That is to be
    # expected and is not a problem with Tcl.
    set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#]
    http::wait $token
    http::status $token
    # error codes vary among platforms.
} -cleanup {
    catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -body {
    set before [chan names]
    set token [http::geturl $url -headers {X-Connection keep-alive}]
    http::cleanup $token
    update
    set after [chan names]
    expr {$before eq $after}
} -result 1

test http-5.1 {http::formatQuery} {
    http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value%20two}
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0D%0Aline2%0D%0Aline3}
test http-5.4 {http::formatQuery} {
    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2}
test http-5.5 {http::formatQuery} {
    set enc [http::config -urlencoding]
    http::config -urlencoding iso8859-1
    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
    http::config -urlencoding $enc
    set res
} {name1=~bwelch&name2=%A1%A2%A2}

test http-6.1 {http::ProxyRequired} -body {
    http::config -proxyhost [info hostname] -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    upvar #0 $token data
    set data(body)
} -cleanup {
    http::config -proxyhost {} -proxyport {}
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http:$url</h2>
</body></html>"

test http-7.1 {http::mapReply} {
    http::mapReply "abc\$\[\]\"\\()\}\{"
} {abc%24%5B%5D%22%5C%28%29%7D%7B}
test http-7.2 {http::mapReply} {
    # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
    # so make sure this gets converted to utf-8 then urlencoded.
    http::mapReply "\u2208"
} {%E2%88%88}
test http-7.3 {http::formatQuery} -setup {
    set enc [http::config -urlencoding]
} -returnCodes error -body {
    # this would be reverting to http <=2.4 behavior
    http::config -urlencoding ""
    http::mapReply "\u2208"
} -cleanup {
    http::config -urlencoding $enc
} -result "can't read \"formMap(\u2208)\": no such element in array"
test http-7.4 {http::formatQuery} -setup {
    set enc [http::config -urlencoding]


} -body {
    # this would be reverting to http <=2.4 behavior w/o errors
    # (unknown chars become '?')
    http::config -urlencoding "iso8859-1"
    http::mapReply "\u2208"



} -cleanup {
    http::config -urlencoding $enc
} -result {%3F}

 


# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
    thread::release $httpthread
} else {
    close $listen
}

if {[info exists removeHttpd]} {
    removeFile $httpdFile
}

rename bgerror {}
::tcltest::cleanupTests

# Local variables:
# mode: tcl
# End:







<







 







|



|


|


|








|


|









<
<
<

>
>
>
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
|
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
>
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>

>
|
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
>
|
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>
>
|
<
<
<
<
>
>
>
|
<
<
>
|
>
>





<
<
<
<
|
<

|








14
15
16
17
18
19
20

21
22
23
24
25
26
27
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79



80
81
82
83
84










85


























86
87
88




























































89
90
91
92
93
94
95
96




97



98







99
100
101
102
































103
104











105






106



107











108









109


110






































111



112
113
114
115
















































116
117
118
119
120
121
122



































123
124
125







































































126
127
128
129
130
131
132
133

134


















135














136
137
138
139
140
141


























142
143
























144

















145













146



















147
148
149




150
151
152
153


154
155
156
157
158
159
160
161
162




163

164
165
166
167
168
169
170
171
172
173
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2017 by Gerald W. Lester.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2.5


if {[catch {package require http 2} version]} {
    if {[info exists http2]} {
	catch {puts "Cannot load http 2.* package"}
	return
    } else {
	catch {puts "Running http 2.* tests in slave interp"}
................................................................................
    puts stderr $errorInfo
}

set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

 
::tcltest::test http-1.1 {http::config} {
    http::config -useragent UserAgent
    http::config
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
::tcltest::test http-1.2 {http::config} {
    http::config -proxyfilter
} http::ProxyRequired
::tcltest::test http-1.3 {http::config} {
    catch {http::config -junk}
} 1
::tcltest::test http-1.4 {http::config} {
    set savedconf [http::config]
    http::config -proxyhost nowhere.come -proxyport 8080 \
	-proxyfilter myFilter -useragent "Tcl Test Suite" \
	-urlencoding iso8859-1
    set x [http::config]
    http::config {*}$savedconf
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
::tcltest::test http-1.5 {http::config} -returnCodes error -body {
    http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
::tcltest::test http-1.6 {http::config} -setup {
    set oldenc [http::config -urlencoding]
} -body {
    set enc [list [http::config -urlencoding]]
    http::config -urlencoding iso8859-1
    lappend enc [http::config -urlencoding]
} -cleanup {
    http::config -urlencoding $oldenc
} -result {utf-8 iso8859-1}





##
## Happy path
##
::tcltest::test http-2.1 {http::reset} \










    -setup {


























        array set ::http_1 {
            sock none
        }




























































        unset -nocomplain ::http_1(error)
        ::tcltest::testSetup {
            ::fileevent {
                * {
                    returns {Test error}
                    code {error}
                    errorcode {HTTP TEST RESET FILEEVENT}
                }




            }



            ::http::Finish {







                * {
                    returns {No Error}
                    errorcode {}
                    set {
































                        ::http_1 A {
                            status {---}











                        }






                    }



                }











            }









        }


    } \






































    -body {



        list [catch {::http::reset ::http_1}] [info exists ::http_1] [::tcltest::callCount]
    } \
    -result {0 1 {::fileevent,count 2 ::http::Finish,count 1}} \
    -cleanup {
















































        ::tcltest::testCleanup
    }
 
## Test error path
##
::tcltest::test http-2.2 {http::reset} \
    -setup {



































        array set ::http_1 {
            sock none
        }







































































        unset -nocomplain ::http_1(error)
        ::tcltest::testSetup {
            ::fileevent {
                * {
                    returns {Test error}
                    code {error}
                    errorcode {HTTP TEST RESET FILEEVENT}
                }

            }


















            ::http::Finish {














                * {
                    returns {Finish Error}
                    errorcode {}
                    set {
                        ::http_1 A {
                            status {---}


























                            error {{HTTP TEST ERROR}}
                        }
























                    }

















                }













            }



















        }
    } \
    -body {




        list [catch {::http::reset ::http_1} result] [info exists ::http_1] [::tcltest::callCount] $result
    } \
    -result {1 0 {::fileevent,count 2 ::http::Finish,count 1} {HTTP TEST ERROR}} \
    -cleanup {


        ::tcltest::testCleanup
    }
 

# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}






if {[info exists removeHttpd]} {
    ::tcltest::removeFile $httpdFile
}

rename bgerror {}
::tcltest::cleanupTests

# Local variables:
# mode: tcl
# End: