1#
2# Tests for SF bugs
3# ----------------------------------------------------------------------
4#   AUTHOR:  Arnulf Wiedemann
5#            arnulf@wiedemann-pri.de
6# ----------------------------------------------------------------------
7#            Copyright (c) Arnulf Wiedemann
8# ======================================================================
9# See the file "license.terms" for information on usage and
10# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11
12package require tcltest 2.1
13namespace import ::tcltest::test
14::tcltest::loadTestedCommands
15package require itcl
16
17global ::test_status
18
19# ----------------------------------------------------------------------
20#  Test bugs of the SourceForge bug tracker for incrtcl
21# ----------------------------------------------------------------------
22
23test sfbug-163 {upvar has to resolve instance variables in caller} -setup {
24    itcl::class o1 {
25        public method getValue {name} {
26	    upvar $name val
27	    set val 22
28	}
29    }
30    itcl::class o2 {
31	public variable command
32	constructor {cls2} {
33	    $cls2 getValue command
34	}
35	public method b {cls2} {
36	    return $command
37	}
38    }
39    o1 test1
40    o2 test2 test1
41} -body {
42    test2 b test1
43} -cleanup {
44    itcl::delete class o2
45    itcl::delete class o1
46} -result 22
47
48test sfbug-187 {upvar with this variable SF bug #187
49} -body {
50    ::itcl::class foo {
51      method test {} {
52          PopID
53      }
54
55      proc PopID {} {
56        upvar 1 this me
57        set me
58      }
59    }
60    foo bar
61    bar test
62} -result {::bar} \
63  -cleanup {::itcl::delete class foo}
64
65test sfbug-234 {chain with no argument SF bug #234
66} -body {
67    set ::test_status ""
68    itcl::class One {
69	public method t1 {x} {
70            lappend ::test_status "$this One.t1($x)"
71	}
72	public method t2 {} {
73            lappend ::test_status "$this One.t2"
74	}
75    }
76
77    itcl::class Two {
78        inherit One
79
80        public method t1 {x} {
81            lappend ::test_status "$this Two.t1($x)"
82            chain $x
83        }
84
85        public method t2 {} {
86            lappend ::test_status "$this Two.t2"
87            chain
88        }
89    }
90    set y [Two #auto]
91    $y t1 a
92    $y t2
93} -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \
94  -cleanup {::itcl::delete class Two}
95
96test sfbug-236 {problem with inheritance of methods SF bug #236
97} -body {
98    set ::test_status ""
99
100    ::itcl::class c_mem {
101        private method get_ports {}
102        public method get_mem {}
103    }
104
105    ::itcl::class c_rom {
106        inherit c_mem
107        private method get_ports {}
108    }
109
110    ::itcl::body c_rom::get_ports {} {
111        return "toto"
112    }
113
114    ::itcl::body c_mem::get_ports {} {
115        return "tata"
116    }
117
118    ::itcl::body c_mem::get_mem {} {
119        return [concat "titi" [get_ports]]
120    }
121
122    set ptr [c_rom #auto]
123    lappend ::test_status [$ptr get_mem]
124
125# expected output:
126# titi toto
127} -result {{titi toto}} \
128  -cleanup {::itcl::delete class c_rom}
129
130test sfbug-237 { problem with chain command SF bug #237
131} -body {
132    set ::test_status ""
133
134    itcl::class main {
135        constructor {} {
136            lappend ::test_status "OK ITCL constructor"
137	}
138
139        public method init_OK1 { parm } {
140            lappend ::test_status "OK1 MAIN $parm"
141        }
142        public method init_OK2 {} {
143            lappend ::test_status "OK2 MAIN"
144        }
145        public method init_ERR1 {} {
146            lappend ::test_status "ERR1 MAIN"
147        }
148    }
149
150    itcl::class child {
151        inherit main
152
153        constructor {} {}
154
155        public method init_OK1 {} {
156            lappend ::test_status "OK1 CHILD"
157            chain TEST
158        }
159
160        public method init_OK2 {} {
161            lappend ::test_status "OK2 CHILD"
162            next
163        }
164
165        public method init_ERR1 {} {
166            lappend ::test_status "ERR1 CHILD"
167            chain
168        }
169    }
170
171    set obj [child #auto]
172    $obj init_OK1
173    $obj init_OK2
174    $obj init_ERR1
175} -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \
176  -cleanup {::itcl::delete class child}
177
178test sfbug-243 {faulty namespace behaviour SF bug #243
179} -body {
180    set ::test_status ""
181
182    namespace eval ns {}
183
184    itcl::class ns::A {
185        method do {} {nsdo}
186
187        method nsdo {} {
188            lappend ::test_status "body do: [info function do -body]"
189        }
190    }
191
192    [ns::A #auto] do
193
194    itcl::body ns::A::do {} {A::nsdo}
195    [ns::A #auto] do
196
197    itcl::body ns::A::do {} {::ns::A::nsdo}
198    [ns::A #auto] do
199
200    itcl::body ns::A::do {} {ns::A::nsdo}
201    [ns::A #auto] do
202} -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \
203  -cleanup {::itcl::delete class ns::A}
204
205test sfbug-244 { SF bug 244
206} -body {
207    set ::test_status ""
208
209    proc foo {body} {
210        uplevel $body
211    }
212
213    itcl::class A {
214      method do {body} {foo $body}
215      method do2 {} {lappend ::test_status done}
216    }
217
218    set y [A #auto]
219    $y  do {
220        lappend ::test_status "I'm $this"
221        do2
222    }
223} -result {{I'm ::a0} done} \
224  -cleanup {::itcl::delete class A; rename foo {}}
225
226test sfbug-250 { SF bug #250
227} -body {
228    set ::test_status ""
229
230    ::itcl::class A {
231        variable b
232
233        constructor {} {
234            set b [B #auto]
235        }
236
237        public method m1 {} {
238            $b m3
239        }
240
241        public method m2 {} {
242            lappend ::test_status m2
243        }
244    }
245
246    ::itcl::class B {
247        public method m3 {} {
248          uplevel m2
249         }
250    }
251
252    set a [A #auto]
253    $a m1
254
255} -result {m2} \
256  -cleanup {::itcl::delete class A B}
257
258test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx
259} -body {
260    set ::test_status ""
261
262    itcl::class foo {
263        method kerplunk {args} {
264            lappend ::test_status [info level 0]
265            lappend ::test_status [::info level 0]
266            lappend ::test_status [[namespace which info] level 0]
267       }
268    }
269
270    [foo #auto] kerplunk hello world
271} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
272  -cleanup {::itcl::delete class foo}
273
274test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb]
275} -body {
276    set interp [interp create]
277    set ::test_status ""
278    $interp eval {
279      oo::class destroy
280    }
281    lappend ::test_status "::oo::class destroy worked"
282    if {[catch {
283      $interp eval [::tcltest::loadScript]
284      $interp eval {
285        package require itcl
286      }
287    } msg]} {
288      lappend ::test_status $msg
289    }
290} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \
291  -cleanup {interp delete $interp}
292
293test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb]
294} -body {
295    set interp [interp create]
296    set ::test_status ""
297    $interp eval {set ::tcl::inl_mem_test 0}
298    $interp eval [::tcltest::loadScript]
299    $interp eval {
300      package require itcl
301
302      oo::class destroy
303    }
304    lappend ::test_status "::oo::class destroy worked"
305    if {[catch {
306      $interp eval {
307        ::itcl::class ::test {}
308      }
309    } msg]} {
310      lappend ::test_status $msg
311    }
312} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \
313  -cleanup {interp delete $interp}
314
315test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb]
316} -body {
317    set interp [interp create]
318    set ::test_status ""
319    $interp eval {set ::tcl::inl_mem_test 0}
320    $interp eval [::tcltest::loadScript]
321    $interp eval {
322      package require itcl
323
324      ::itcl::class ::test {}
325    }
326    lappend ::test_status "::test class created"
327    $interp eval {
328      oo::class destroy
329    }
330    lappend ::test_status "::oo::class destroy worked"
331    if {[catch {
332      $interp eval {
333        ::test x
334      }
335    } msg]} {
336      lappend ::test_status $msg
337    }
338    if {[catch {
339      $interp eval {
340        ::itcl::class ::test2 {inherit ::test}
341      }
342    } msg]} {
343      lappend ::test_status $msg
344    }
345} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \
346  -cleanup {interp delete $interp}
347
348test sfbug-255 { SF bug #255
349} -body {
350    set ::test_status ""
351
352    proc ::sfbug_255_do_uplevel { body } {
353        uplevel 1 $body
354    }
355
356    proc ::sfbug_255_testclass { pathName args } {
357        uplevel TestClass $pathName $args
358    }
359
360    ::itcl::class TestClass {
361        public variable property "value"
362        constructor {} {
363        }
364
365        private method internal-helper {} {
366            return "TestClass::internal-helper"
367        }
368
369        public method api-call {} {
370            lappend ::test_status "TestClass::api-call"
371            lappend ::test_status [internal-helper]
372            lappend ::test_status [sfbug_255_do_uplevel { internal-helper }]
373            lappend ::test_status [cget -property]
374            sfbug_255_do_uplevel { lappend ::test_status [cget -property] }
375        }
376    }
377
378    [::sfbug_255_testclass tc] api-call
379} -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \
380  -cleanup {::itcl::delete class TestClass}
381
382test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23
383} -body {
384    ::itcl::class ::Naughty {
385        private method die {} {
386        }
387    }
388    ::Naughty die
389} -cleanup {
390    ::itcl::delete class ::Naughty
391} -result {die}
392
393test sfbug-256 { SF bug #256
394} -body {
395    set ::test_status ""
396
397    proc ::sfbug_256_do_uplevel { body } {
398        uplevel 1 $body
399    }
400
401    proc ::sfbug_256_testclass { pathName args } {
402        uplevel TestClass256 $pathName $args
403    }
404
405    ::itcl::class TestClass256 {
406        public variable property "value"
407        constructor {} {
408        }
409
410        private method internal-helper {} {
411            lappend ::test_status "TestClass::internal-helper"
412            sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
413        }
414
415        public method api-call {} {
416            lappend ::test_status "TestClass::api-call"
417            lappend ::test_status [internal-helper]
418            lappend ::test_status [sfbug_256_do_uplevel { internal-helper }]
419            lappend ::test_status [cget -property]
420            sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
421        }
422    }
423
424    [::sfbug_256_testclass tc] api-call
425} -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} \
426  -cleanup {::itcl::delete class TestClass256}
427
428test sfbug-257 { SF bug #257
429} -body {
430    set interp [interp create]
431    $interp eval {set ::tcl::inl_mem_test 0}
432    $interp eval [::tcltest::loadScript]
433    $interp eval {
434      package require itcl
435      set ::test_status ""
436      ::itcl::class ::cl1 {
437        method m1 {} {
438          ::oo::class destroy
439          lappend ::test_status "method Hello World"
440        }
441        proc p1 {} {
442          lappend ::test_status "proc Hello World"
443        }
444      }
445      set obj1 [::cl1 #auto]
446      ::cl1::p1
447      $obj1 p1
448      $obj1 m1
449
450      catch {
451      $obj1 m1
452      ::cl1::p1
453      } msg
454      lappend ::test_status $msg
455    }
456} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
457  -cleanup {interp delete $interp}
458
459test sfbug-259 { SF bug #257 } -setup {
460    interp create child
461    load {} Itcl child
462} -cleanup {
463    interp delete child
464} -body {
465    child eval {
466proc do_uplevel { body } {
467    uplevel 1 $body
468}
469proc ::testclass { pathName args } {
470    uplevel TestClass $pathName $args
471}
472itcl::class TestClass {
473    constructor {} {}
474    public variable property "value"
475    public method api-call {}
476    protected method internal-helper {}
477}
478itcl::body TestClass::internal-helper {} {
479}
480itcl::configbody TestClass::property {
481    internal-helper
482}
483itcl::body TestClass::api-call {} {
484    do_uplevel {configure -property blah}
485}
486set tc [::testclass .]
487$tc api-call
488    }
489}
490
491test sfbug-261 { SF bug #261 } -setup {
492    itcl::class A {
493	public method a1 {} {a2}
494	public method a2 {} {uplevel a3 hello}
495	public method a3 {s} {return $s}
496    }
497    A x
498} -body {
499    x a1
500} -cleanup {
501    itcl::delete class A
502} -result hello
503
504test sfbug-265.1 { SF bug #265 } -setup {
505    itcl::class C {}
506} -body {
507    namespace eval A {C c}
508    namespace eval B {C c}
509} -cleanup {
510    itcl::delete class C
511    namespace delete A B
512} -result c
513test sfbug-265.2 { SF bug #265 } -setup {
514    itcl::class C {}
515    itcl::class B::C {}
516} -body {
517    C ::A::B
518    B::C ::A
519} -cleanup {
520    itcl::delete class B::C
521    itcl::delete class C
522    namespace delete A B
523} -result ::A
524
525test sfbug-268 { SF bug #268 } -setup {
526    itcl::class C {
527	private variable v
528	destructor {error foo}
529	public method demo {} {set v 0}
530    }
531    C c
532} -body {
533    catch {itcl::delete object c}
534    c demo
535} -cleanup {
536    rename c {}
537    itcl::delete class C
538} -result 0
539
540test sfbug-273 { SF bug #273 } -setup {
541    itcl::class C {
542	public proc call {m} {$m}
543	public proc crash {} {
544	    call null
545	    info frame 2
546	    return ok
547	}
548	public proc null {} {}
549    }
550} -body {
551    C::call crash
552} -cleanup {
553    itcl::delete class C
554} -result ok
555
556
557test sfbug-276.0 { SF bug #276 } -setup {
558  set ::answer {}
559  itcl::class A {
560    constructor {} {
561      lappend ::answer [uplevel namespace current]
562    }
563  }
564  itcl::class B {
565    inherit A
566    constructor {} {}
567  }
568} -body {
569  B b
570  set ::answer
571} -cleanup {
572  itcl::delete class A B
573  unset -nocomplain ::answer
574} -result ::B
575
576test sfbug-276.1 { SF bug #276 } -setup {
577  set ::answer {}
578  itcl::class A {
579    constructor {} {
580      lappend ::answer [uplevel namespace current]
581    }
582  }
583  itcl::class E {
584    constructor {} {
585      lappend ::answer [uplevel namespace current]
586    }
587  }
588  itcl::class B {
589    inherit A E
590    constructor {} {}
591  }
592} -body {
593  B b
594  set ::answer
595} -cleanup {
596  itcl::delete class A B E
597  unset -nocomplain ::answer
598} -result {::B ::B}
599
600test fossil-9.0 {d0126511d9} -setup {
601    itcl::class N::B {}
602} -body {
603    itcl::class N {}
604} -cleanup {
605    itcl::delete class N::B N
606} -result {}
607
608test fossil-9.1 {d0126511d9} -setup {
609    itcl::class N::B {}
610    itcl::delete class N::B
611    namespace delete N
612} -body {
613    itcl::class N {}
614} -cleanup {
615    itcl::delete class N
616    catch {namespace delete N}
617} -result {}
618
619test fossil-9.2 {ec215db901} -setup {
620    set ::answer {}
621    itcl::class Object {
622	constructor {} {set n 1} {set ::answer $n}
623    }
624} -body {
625    Object foo
626    set ::answer
627} -cleanup {
628    itcl::delete class Object
629    unset -nocomplain ::answer
630} -result 1
631
632test fossil-9.3 {c45384364c} -setup {
633    itcl::class A {
634	method demo script {uplevel 1 $script}
635    }
636    A a
637    itcl::class B {
638	method demo script {eval $script; a demo $script}
639    }
640    B b
641} -body {
642    b demo {lappend result $this}
643} -cleanup {
644    itcl::delete class A B
645} -result {::b ::b}
646
647test fossil-9.4 {9eea4912b9} -setup {
648    itcl::class A {
649	public method foo WRONG
650    }
651} -body {
652    itcl::body A::foo {RIGHT} {}
653    A a
654    a info args foo
655} -cleanup {
656    itcl::delete class A
657} -result RIGHT
658
659test sfbugs-281 {Resolve inherited common} -setup {
660    itcl::class Parent {protected common x 0}
661} -cleanup {
662    itcl::delete class Parent
663} -body {
664    itcl::class Child {
665	inherit Parent
666	set Parent::x
667    }
668} -result {}
669
670
671
672#test sfbug-xxx { SF bug xxx
673#} -body {
674#    set ::test_status ""
675#
676#} -result {::bar} \
677#  -cleanup {::itcl::delete class yyy}
678
679::tcltest::cleanupTests
680return
681