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: |
7fcd7262f62eb3d5a185a4abf5e62200 |
| 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
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 | # 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 | < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# 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"}
|
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
puts stderr $errorInfo
}
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
| | | | | | | < < < < < < < < < < < < < > | < < < < < < < < < < < < < < < < < > | | | < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < | < < | < | < | < < < < < < < < < < < < < < < < < | < < < | < < < < < < | < < | < | | | | < < | < < < < < < < < | < < < < < < < < < < < | < < < < < < | < < < | < < < < < < < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < < | < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < | > | < | | | > | < | | < | | | < < < < < < < < > | < | < < < < < < < < < < < < | | < | < < | < < < < < < < < < < < < < < | | < < < < < < < | < < < < < < < < < < < < < < < < < | | < < > > > > | < < < | < < < | > | < | | > < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | | 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 |
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:
|