+++ /dev/null
-#
-# Tests for SF bugs
-# ----------------------------------------------------------------------
-# AUTHOR: Arnulf Wiedemann
-# arnulf@wiedemann-pri.de
-# ----------------------------------------------------------------------
-# Copyright (c) Arnulf Wiedemann
-# ======================================================================
-# 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.1
-namespace import ::tcltest::test
-::tcltest::loadTestedCommands
-package require itcl
-
-global ::test_status
-
-# ----------------------------------------------------------------------
-# Test bugs of the SourceForge bug tracker for incrtcl
-# ----------------------------------------------------------------------
-test sfbug-187 {upvar with this variable SF bug #187
-} -body {
- ::itcl::class foo {
- method test {} {
- PopID
- }
-
- proc PopID {} {
- upvar 1 this me
- set me
- }
- }
- foo bar
- bar test
-} -result {::bar} \
- -cleanup {::itcl::delete class foo}
-
-test sfbug-234 {chain with no argument SF bug #234
-} -body {
- set ::test_status ""
- itcl::class One {
- public method t1 {x} {
- lappend ::test_status "$this One.t1($x)"
- }
- public method t2 {} {
- lappend ::test_status "$this One.t2"
- }
- }
-
- itcl::class Two {
- inherit One
-
- public method t1 {x} {
- lappend ::test_status "$this Two.t1($x)"
- chain $x
- }
-
- public method t2 {} {
- lappend ::test_status "$this Two.t2"
- chain
- }
- }
- set y [Two #auto]
- $y t1 a
- $y t2
-} -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \
- -cleanup {::itcl::delete class Two}
-
-test sfbug-236 {problem with inheritance of methods SF bug #236
-} -body {
- set ::test_status ""
-
- ::itcl::class c_mem {
- private method get_ports {}
- public method get_mem {}
- }
-
- ::itcl::class c_rom {
- inherit c_mem
- private method get_ports {}
- }
-
- ::itcl::body c_rom::get_ports {} {
- return "toto"
- }
-
- ::itcl::body c_mem::get_ports {} {
- return "tata"
- }
-
- ::itcl::body c_mem::get_mem {} {
- return [concat "titi" [get_ports]]
- }
-
- set ptr [c_rom #auto]
- lappend ::test_status [$ptr get_mem]
-
-# expected output:
-# titi toto
-} -result {{titi toto}} \
- -cleanup {::itcl::delete class c_rom}
-
-test sfbug-237 { problem with chain command SF bug #237
-} -body {
- set ::test_status ""
-
- itcl::class main {
- constructor {} {
- lappend ::test_status "OK ITCL constructor"
- }
-
- public method init_OK1 { parm } {
- lappend ::test_status "OK1 MAIN $parm"
- }
- public method init_OK2 {} {
- lappend ::test_status "OK2 MAIN"
- }
- public method init_ERR1 {} {
- lappend ::test_status "ERR1 MAIN"
- }
- }
-
- itcl::class child {
- inherit main
-
- constructor {} {}
-
- public method init_OK1 {} {
- lappend ::test_status "OK1 CHILD"
- chain TEST
- }
-
- public method init_OK2 {} {
- lappend ::test_status "OK2 CHILD"
- next
- }
-
- public method init_ERR1 {} {
- lappend ::test_status "ERR1 CHILD"
- chain
- }
- }
-
- set obj [child #auto]
- $obj init_OK1
- $obj init_OK2
- $obj init_ERR1
-} -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \
- -cleanup {::itcl::delete class child}
-
-test sfbug-243 {faulty namespace behaviour SF bug #243
-} -body {
- set ::test_status ""
-
- namespace eval ns {}
-
- itcl::class ns::A {
- method do {} {nsdo}
-
- method nsdo {} {
- lappend ::test_status "body do: [info function do -body]"
- }
- }
-
- [ns::A #auto] do
-
- itcl::body ns::A::do {} {A::nsdo}
- [ns::A #auto] do
-
- itcl::body ns::A::do {} {::ns::A::nsdo}
- [ns::A #auto] do
-
- itcl::body ns::A::do {} {ns::A::nsdo}
- [ns::A #auto] do
-} -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \
- -cleanup {::itcl::delete class ns::A}
-
-test sfbug-244 { SF bug 244
-} -body {
- set ::test_status ""
-
- proc foo {body} {
- uplevel $body
- }
-
- itcl::class A {
- method do {body} {foo $body}
- method do2 {} {lappend ::test_status done}
- }
-
- set y [A #auto]
- $y do {
- lappend ::test_status "I'm $this"
- do2
- }
-} -result {{I'm ::a0} done} \
- -cleanup {::itcl::delete class A; rename foo {}}
-
-test sfbug-250 { SF bug #250
-} -body {
- set ::test_status ""
-
- ::itcl::class A {
- variable b
-
- constructor {} {
- set b [B #auto]
- }
-
- public method m1 {} {
- $b m3
- }
-
- public method m2 {} {
- lappend ::test_status m2
- }
- }
-
- ::itcl::class B {
- public method m3 {} {
- uplevel m2
- }
- }
-
- set a [A #auto]
- $a m1
-
-} -result {m2} \
- -cleanup {::itcl::delete class A B}
-
-test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx
-} -body {
- set ::test_status ""
-
- itcl::class foo {
- method kerplunk {args} {
- lappend ::test_status [info level 0]
- lappend ::test_status [::info level 0]
- lappend ::test_status [[namespace which info] level 0]
- }
- }
-
- [foo #auto] kerplunk hello world
-} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
- -cleanup {::itcl::delete class foo}
-
-test sfbug-254 { SF bug #254
-} -body {
- set interp [interp create]
- $interp eval {
- package require itcl
-
- set ::test_status ""
- oo::class destroy
- lappend ::test_status "::oo::class destroy worked"
- }
-} -result {{::oo::class destroy worked}} \
- -cleanup { }
-
-test sfbug-255 { SF bug #255
-} -body {
- set ::test_status ""
-
- proc ::sfbug_255_do_uplevel { body } {
- uplevel 1 $body
- }
-
- proc ::sfbug_255_testclass { pathName args } {
- uplevel TestClass $pathName $args
- }
-
- ::itcl::class TestClass {
- public variable property "value"
- constructor {} {
- }
-
- private method internal-helper {} {
- return "TestClass::internal-helper"
- }
-
- public method api-call {} {
- lappend ::test_status "TestClass::api-call"
- lappend ::test_status [internal-helper]
- lappend ::test_status [sfbug_255_do_uplevel { internal-helper }]
- lappend ::test_status [cget -property]
- sfbug_255_do_uplevel { lappend ::test_status [cget -property] }
- }
- }
-
- [::sfbug_255_testclass tc] api-call
-} -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \
- -cleanup {::itcl::delete class TestClass}
-
-test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23
-} -body {
- set ::test_status ""
- ::itcl::class ::Naughty {
- private method die {} {
- }
- }
- catch {::Naughty die} msg
- lappend ::test_status $msg
-} -result {{invalid command name "die"}} \
- -cleanup {::itcl::delete class ::Naughty}
-
-test sfbug-256 { SF bug #256
-} -body {
- set ::test_status ""
-
- proc ::sfbug_256_do_uplevel { body } {
- uplevel 1 $body
- }
-
- proc ::sfbug_256_testclass { pathName args } {
- uplevel TestClass256 $pathName $args
- }
-
- ::itcl::class TestClass256 {
- public variable property "value"
- constructor {} {
- }
-
- private method internal-helper {} {
- lappend ::test_status "TestClass::internal-helper"
- sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
- }
-
- public method api-call {} {
- lappend ::test_status "TestClass::api-call"
- lappend ::test_status [internal-helper]
- lappend ::test_status [sfbug_256_do_uplevel { internal-helper }]
- lappend ::test_status [cget -property]
- sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
- }
- }
-
- [::sfbug_256_testclass tc] api-call
-} -result {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value} value value} \
- -cleanup {::itcl::delete class TestClass256}
-
-test sfbug-257 { SF bug #257
-} -body {
- set interp [interp create]
- $interp eval {
- package require itcl
- set ::test_status ""
- ::itcl::class ::cl1 {
- method m1 {} {
- ::oo::class destroy
- lappend ::test_status "method Hello World"
- }
- proc p1 {} {
- lappend ::test_status "proc Hello World"
- }
- }
- set obj1 [::cl1 #auto]
- ::cl1::p1
- $obj1 p1
- $obj1 m1
-
- catch {
- $obj1 m1
- ::cl1::p1
- } msg
- lappend ::test_status $msg
- }
-} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
- -cleanup {catch {::itcl::delete class ::cl1}}
-
-test sfbug-259 { SF bug #257 } -setup {
- interp create slave
- load {} Itcl slave
-} -cleanup {
- interp delete slave
-} -body {
- slave eval {
-proc do_uplevel { body } {
- uplevel 1 $body
-}
-proc ::testclass { pathName args } {
- uplevel TestClass $pathName $args
-}
-itcl::class TestClass {
- constructor {} {}
- public variable property "value"
- public method api-call {}
- protected method internal-helper {}
-}
-itcl::body TestClass::internal-helper {} {
-}
-itcl::configbody TestClass::property {
- internal-helper
-}
-itcl::body TestClass::api-call {} {
- do_uplevel {configure -property blah}
-}
-set tc [::testclass .]
-$tc api-call
- }
-}
-
-test sfbug-261 { SF bug #261 } -setup {
- itcl::class A {
- public method a1 {} {a2}
- public method a2 {} {uplevel a3 hello}
- public method a3 {s} {return $s}
- }
- A x
-} -body {
- x a1
-} -cleanup {
- itcl::delete class A
-} -result hello
-
-#test sfbug-xxx { SF bug xxx
-#} -body {
-# set ::test_status ""
-#
-#} -result {::bar} \
-# -cleanup {::itcl::delete class yyy}
-
-::tcltest::cleanupTests
-return
OSDN Git Service
