1# This file contains a collection of tests for functionality originally
2# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
3# the tests and generates output for errors. No output means no errors were
4# found.
5#
6# Copyright © 2014-2016 Andreas Kupries
7# Copyright © 2018 Donal K. Fellows
8#
9# See the file "license.terms" for information on usage and redistribution of
10# this file, and for a DISCLAIMER OF ALL WARRANTIES.
11
12package require tcl::oo 1.0.3
13if {"::tcltest" ni [namespace children]} {
14    package require tcltest 2.5
15    namespace import -force ::tcltest::*
16}
17
18test ooUtil-1.1 {TIP 478: classmethod} -setup {
19    oo::class create parent
20} -body {
21    oo::class create ActiveRecord {
22	superclass parent
23        classmethod find args {
24	    return "[self] called with arguments: $args"
25	}
26    }
27    oo::class create Table {
28        superclass ActiveRecord
29    }
30    Table find foo bar
31} -cleanup {
32    parent destroy
33} -result {::Table called with arguments: foo bar}
34test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
35    namespace eval ::testns {}
36} -body {
37    namespace eval ::testns {
38	oo::class create ActiveRecord {
39	    classmethod find args {
40		return "[self] called with arguments: $args"
41	    }
42	}
43	oo::class create Table {
44	    superclass ActiveRecord
45	}
46    }
47    testns::Table find foo bar
48} -cleanup {
49    namespace delete ::testns
50} -result {::testns::Table called with arguments: foo bar}
51test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
52    oo::class create parent
53} -body {
54    oo::class create TestClass {
55        superclass oo::class parent
56        self method create {name ignore body} {
57            next $name $body
58        }
59    }
60    TestClass create okay {} {}
61} -cleanup {
62    parent destroy
63} -result {::okay}
64test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
65    oo::class create parent
66} -body {
67    oo::class create ActiveRecord {
68	superclass parent
69        classmethod find args {
70	    return "[self] called with arguments: $args"
71	}
72    }
73    oo::class create Table {
74        superclass ActiveRecord
75    }
76    oo::class create SubTable {
77        superclass Table
78    }
79    SubTable find foo bar
80} -cleanup {
81    parent destroy
82} -result {::SubTable called with arguments: foo bar}
83test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
84    oo::class create parent
85} -body {
86    oo::class create ActiveRecord {
87	superclass parent
88        classmethod find args {
89	    return "[self] called with arguments: $args"
90	}
91    }
92    oo::class create Table {
93	superclass ActiveRecord
94    }
95    set t [Table new]
96    $t find 1 2 3
97} -cleanup {
98    parent destroy
99} -result {::Table called with arguments: 1 2 3}
100test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
101    oo::class create parent
102} -body {
103    oo::class create ActiveRecord {
104	superclass parent
105        classmethod find args {
106	    return "[self] called with arguments: $args"
107	}
108    }
109    oo::class create Table {
110	superclass ActiveRecord
111	unexport find
112    }
113    set t [Table new]
114    $t find 1 2 3
115} -returnCodes error -cleanup {
116    parent destroy
117} -match glob -result {unknown method "find": must be *}
118test ooUtil-1.7 {} -setup {
119    oo::class create parent
120} -body {
121    oo::class create Foo {
122	superclass parent
123        classmethod bar {} {
124            puts "This is in the class; self is [self]"
125            my meee
126        }
127        classmethod meee {} {
128            puts "This is meee"
129        }
130    }
131    oo::class create Grill {
132        superclass Foo
133        classmethod meee {} {
134            puts "This is meee 2"
135        }
136    }
137    list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
138} -cleanup {
139    parent destroy
140} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
141# Two tests to confirm that we correctly initialise the scripted part of TclOO
142# in child interpreters. This is slightly tricky at the implementation level
143# because we cannot count on either [source] or [open] being available.
144test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
145    set childinterp [interp create]
146} -body {
147    $childinterp eval {
148	oo::class create ActiveRecord {
149	    classmethod find args {
150		return "[self] called with arguments: $args"
151	    }
152	}
153	oo::class create Table {
154	    superclass ActiveRecord
155	}
156	# This is confirming that this is not the parent interpreter
157	list [Table find foo bar] [info globals childinterp]
158    }
159} -cleanup {
160    interp delete $childinterp
161} -result {{::Table called with arguments: foo bar} {}}
162test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
163    set safeinterp [interp create -safe]
164} -body {
165    $safeinterp eval {
166	oo::class create ActiveRecord {
167	    classmethod find args {
168		return "[self] called with arguments: $args"
169	    }
170	}
171	oo::class create Table {
172	    superclass ActiveRecord
173	}
174	# This is confirming that this is a (basic) safe interpreter
175	list [Table find foo bar] [info commands source]
176    }
177} -cleanup {
178    interp delete $safeinterp
179} -result {{::Table called with arguments: foo bar} {}}
180
181test ooUtil-2.1 {TIP 478: callback generation} -setup {
182    oo::class create parent
183} -body {
184    oo::class create c {
185	superclass parent
186	method CallMe {} { return ok,[self] }
187	method makeCall {} {
188	    return [callback CallMe]
189	}
190    }
191    c create ::context
192    set cb [context makeCall]
193    {*}$cb
194} -cleanup {
195    parent destroy
196} -result {ok,::context}
197test ooUtil-2.2 {TIP 478: callback generation} -setup {
198    oo::class create parent
199} -body {
200    oo::class create c {
201	superclass parent
202	method CallMe {a b c} { return ok,[self],$a,$b,$c }
203	method makeCall {b} {
204	    return [callback CallMe 123 $b]
205	}
206    }
207    c create ::context
208    set cb [context makeCall "a b c"]
209    {*}$cb PQR
210} -cleanup {
211    parent destroy
212} -result {ok,::context,123,a b c,PQR}
213test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup {
214    oo::class create parent
215} -body {
216    oo::class create c {
217	superclass parent
218	method CallMe {} { return ok,[self] }
219	method makeCall {} {
220	    return [mymethod CallMe]
221	}
222    }
223    c create ::context
224    set cb [context makeCall]
225    {*}$cb
226} -cleanup {
227    parent destroy
228} -result {ok,::context}
229test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup {
230    oo::class create parent
231} -body {
232    oo::class create c {
233	superclass parent
234	method CallMe {a b c} { return ok,[self],$a,$b,$c }
235	method makeCall {b} {
236	    return [mymethod CallMe 123 $b]
237	}
238    }
239    c create ::context
240    set cb [context makeCall "a b c"]
241    {*}$cb PQR
242} -cleanup {
243    parent destroy
244} -result {ok,::context,123,a b c,PQR}
245test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup {
246    oo::class create parent
247} -body {
248    oo::class create c {
249	superclass parent
250	method makeCall {b} {
251	    return [callback CallMe 123 $b]
252	}
253    }
254    c create ::context
255    set cb [context makeCall "a b c"]
256    set result [list [catch {{*}$cb PQR} msg] $msg]
257    oo::objdefine context {
258	method CallMe {a b c} { return ok,[self],$a,$b,$c }
259    }
260    lappend result [{*}$cb PQR]
261} -cleanup {
262    parent destroy
263} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
264test ooUtil-2.6 {TIP 478: callback use case} -setup {
265    oo::class create parent
266    unset -nocomplain x
267} -body {
268    oo::class create c {
269	superclass parent
270	variable count
271	constructor {var} {
272	    set count 0
273	    upvar 1 $var v
274	    trace add variable v write [callback TraceCallback]
275	}
276	method count {} {return $count}
277	method TraceCallback {name1 name2 op} {
278	    incr count
279	}
280    }
281    set o [c new x]
282    for {set x 0} {$x < 5} {incr x} {}
283    $o count
284} -cleanup {
285    unset -nocomplain x
286    parent destroy
287} -result 6
288
289test ooUtil-3.1 {TIP 478: class initialisation} -setup {
290    oo::class create parent
291    catch {rename ::foobar-3.1 {}}
292} -body {
293    oo::class create ::cls {
294	superclass parent
295	initialise {
296	    proc foobar-3.1 {} {return ok}
297	}
298	method calls {} {
299	    list [catch foobar-3.1 msg] $msg \
300		[namespace eval [info object namespace [self class]] foobar-3.1]
301	}
302    }
303    [cls new] calls
304} -cleanup {
305    parent destroy
306} -result {1 {invalid command name "foobar-3.1"} ok}
307test ooUtil-3.2 {TIP 478: class variables} -setup {
308    oo::class create parent
309    catch {rename ::foobar-3.1 {}}
310} -body {
311    oo::class create ::cls {
312	superclass parent
313	initialise {
314	    variable x 123
315	}
316	method call {} {
317	    classvariable x
318	    incr x
319	}
320    }
321    cls create a
322    cls create b
323    cls create c
324    list [a call] [b call] [c call] [a call] [b call] [c call]
325} -cleanup {
326    parent destroy
327} -result {124 125 126 127 128 129}
328test ooUtil-3.3 {TIP 478: class initialisation} -setup {
329    oo::class create parent
330    catch {rename ::foobar-3.3 {}}
331} -body {
332    oo::class create ::cls {
333	superclass parent
334	initialize {
335	    proc foobar-3.3 {} {return ok}
336	}
337	method calls {} {
338	    list [catch foobar-3.3 msg] $msg \
339		[namespace eval [info object namespace [self class]] foobar-3.3]
340	}
341    }
342    [cls new] calls
343} -cleanup {
344    parent destroy
345} -result {1 {invalid command name "foobar-3.3"} ok}
346test ooUtil-3.4 {TIP 478: class initialisation} -setup {
347    oo::class create parent
348    catch {rename ::appendToResultVar {}}
349    proc ::appendToResultVar args {
350	lappend ::result {*}$args
351    }
352    set result {}
353} -body {
354    trace add execution oo::define::initialise enter appendToResultVar
355    oo::class create ::cls {
356	superclass parent
357	initialize {proc xyzzy {} {}}
358    }
359    return $result
360} -cleanup {
361    catch {
362	trace remove execution oo::define::initialise enter appendToResultVar
363    }
364    rename ::appendToResultVar {}
365    parent destroy
366} -result {{initialize {proc xyzzy {} {}}} enter}
367test ooUtil-3.5 {TIP 478: class initialisation} -body {
368    oo::define oo::object {
369	::list [::namespace which initialise] [::namespace which initialize] \
370	     [::namespace origin initialise] [::namespace origin initialize]
371    }
372} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
373
374test ooUtil-4.1 {TIP 478: singleton} -setup {
375    oo::class create parent
376} -body {
377    oo::singleton create xyz {
378	superclass parent
379    }
380    set x [xyz new]
381    set y [xyz new]
382    set z [xyz new]
383    set code [catch {$x destroy} msg]
384    set p [xyz new]
385    lappend code [catch {rename $x ""}]
386    set q [xyz new]
387    string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
388} -cleanup {
389    parent destroy
390} -result {1 0 ONE ONE ONE ONE TWO TWO}
391test ooUtil-4.2 {TIP 478: singleton errors} -setup {
392    oo::class create parent
393} -body {
394    oo::singleton create xyz {
395	superclass parent
396    }
397    [xyz new] destroy
398} -returnCodes error -cleanup {
399    parent destroy
400} -result {may not destroy a singleton object}
401test ooUtil-4.3 {TIP 478: singleton errors} -setup {
402    oo::class create parent
403} -body {
404    oo::singleton create xyz {
405	superclass parent
406    }
407    oo::copy [xyz new]
408} -returnCodes error -cleanup {
409    parent destroy
410} -result {may not clone a singleton object}
411
412
413test ooUtil-5.1 {TIP 478: abstract} -setup {
414    oo::class create parent
415} -body {
416    oo::abstract create xyz {
417	superclass parent
418	method foo {} {return 123}
419    }
420    oo::class create pqr {
421	superclass xyz
422	method bar {} {return 456}
423    }
424    set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
425    set x [pqr new]
426    set y [pqr create ::y]
427    lappend codes [$x foo] [$x bar] $y
428} -cleanup {
429    parent destroy
430} -result {1 1 1 123 456 ::y}
431
432test ooUtil-6.1 {TIP 478: classvarable} -setup {
433    oo::class create parent
434} -body {
435    oo::class create xyz {
436	superclass parent
437	initialise {
438	    variable x 1 y 2
439	}
440	method a {} {
441	    classvariable x
442	    incr x
443	}
444	method b {} {
445	    classvariable y
446	    incr y
447	}
448	method c {} {
449	    classvariable x y
450	    list $x $y
451	}
452    }
453    set p [xyz new]
454    set q [xyz new]
455    set result [list [$p c] [$q c]]
456    $p a
457    $q b
458    lappend result [[xyz new] c]
459} -cleanup {
460    parent destroy
461} -result {{1 2} {1 2} {2 3}}
462test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
463    oo::class create parent
464} -body {
465    oo::class create xyz {
466	superclass parent
467	method a {} {
468	    classvariable x(1)
469	    incr x(1)
470	}
471    }
472    set p [xyz new]
473    set q [xyz new]
474    list [$p a] [$q a]
475} -returnCodes error -cleanup {
476    parent destroy
477} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
478test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
479    oo::class create parent
480} -body {
481    oo::class create xyz {
482	superclass parent
483	method a {} {
484	    classvariable ::x
485	    incr x
486	}
487    }
488    set p [xyz new]
489    set q [xyz new]
490    list [$p a] [$q a]
491} -returnCodes error -cleanup {
492    parent destroy
493} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
494
495test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
496    oo::class create parent
497} -body {
498    oo::class create cls {
499	superclass parent
500	method foo {} {return "in foo of [self]"}
501	method Bar {} {return "in bar of [self]"}
502	method Grill {} {return "in grill of [self]"}
503	export eval
504	constructor {} {
505	    link foo
506	    link {bar Bar} {grill Grill}
507	}
508    }
509    cls create o
510    o eval {list [foo] [bar] [grill]}
511} -cleanup {
512    parent destroy
513} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
514test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
515    oo::class create parent
516} -body {
517    oo::class create cls {
518	superclass parent
519	method foo {} {return "in foo of [self]"}
520	constructor {cmd} {
521	    link [list ::$cmd foo]
522	}
523    }
524    cls create o pqr
525    list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
526} -cleanup {
527    parent destroy
528} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
529
530# Tests that verify issues detected with the tcllib version of the code
531test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
532    oo::class create animal {}
533    namespace eval ::ooutiltest {
534	oo::class create pet { superclass animal }
535    }
536} -body {
537    namespace eval ::ooutiltest {
538	oo::class create dog { superclass pet }
539    }
540} -cleanup {
541    namespace delete ooutiltest
542    rename animal {}
543} -result {::ooutiltest::dog}
544test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
545    oo::class create TestClass {
546        superclass oo::class
547        self method create {name ignore body} {
548            next $name $body
549        }
550    }
551} -body {
552    TestClass create okay {} {}
553} -cleanup {
554    rename TestClass {}
555} -result {::okay}
556
557cleanupTests
558return
559
560# Local Variables:
561# fill-column: 78
562# mode: tcl
563# End:
564