Tcl Source Code

Check-in [6ef91130eb]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:More test cases. More fixes.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: 6ef91130ebf036de477a1f649a6886a7d91c135d91018801650157cd1ae45f5d
User & Date: dkf 2018-06-29 07:15:06
Context
2018-06-30
05:13
Started to write documentation check-in: 844ca4baf1 user: dkf tags: tip-478
2018-06-29
07:15
More test cases. More fixes. check-in: 6ef91130eb user: dkf tags: tip-478
2018-06-28
10:40
Split out TIP 478 tests into their own file. check-in: 5753c80e0e user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

29
30
31
32
33
34
35
36






37

38
39
40
41
42
43
44
45
46
47
48
49
50



51

52
53
54





55
56
57
58
59
60
61
62
63
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"

"::proc ::oo::Helpers::classvariable {name args} {\n"
"    # Get a reference to the class's namespace\n"
"    set ns [info object namespace [uplevel 1 {self class}]]\n"
"    # Double up the list of variable names\n"
"    set vs [list $name $name]\n"






"    foreach v $args {lappend vs $v $v}\n"

"    # Lastly, link the caller's local variables to the class's variables\n"
"    tailcall namespace upvar $ns {*}$vs\n"
"}\n"

"::proc ::oo::Helpers::link {args} {\n"
"    set ns [uplevel 1 {namespace current}]\n"
"    foreach link $args {\n"
"        if {[llength $link] == 2} {\n"
"            lassign $link src dst\n"
"        } else {\n"
"            lassign $link src\n"
"            set dst $src\n"
"        }\n"



"        interp alias {} ${ns}::$src {} ${ns}::my $dst\n"

"    }\n"
"    return\n"
"}\n"






"proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\n"
"}\n"

"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
"    # Create the method on the class if the caller gave arguments and body\n"
"    set argc [llength [info level 0]]\n"
"    if {$argc == 3} {\n"






|
>
>
>
>
>
>
|
>













>
>
>
|
>



>
>
>
>
>

|







29
30
31
32
33
34
35
36
37
38
39
40
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
"    list [uplevel 1 {namespace which my}] $method {*}$args\n"
"}\n"

"::proc ::oo::Helpers::classvariable {name args} {\n"
"    # Get a reference to the class's namespace\n"
"    set ns [info object namespace [uplevel 1 {self class}]]\n"
"    # Double up the list of variable names\n"
"    foreach v [list $name {*}$args] {\n"
"        if {[string match *(*) $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a scalar variable that looks like an array element}]\n"
"        }\n"
"        if {[string match *::* $v]} {\n"
"            return -code error [string cat {bad variable name \"} $v {\": can\'t create a local variable with a namespace separator in it}]\n"
"        }\n"
"        lappend vs $v $v\n"
"    }\n"
"    # Lastly, link the caller's local variables to the class's variables\n"
"    tailcall namespace upvar $ns {*}$vs\n"
"}\n"

"::proc ::oo::Helpers::link {args} {\n"
"    set ns [uplevel 1 {namespace current}]\n"
"    foreach link $args {\n"
"        if {[llength $link] == 2} {\n"
"            lassign $link src dst\n"
"        } else {\n"
"            lassign $link src\n"
"            set dst $src\n"
"        }\n"
"        if {![string match ::* $src]} {\n"
"            set src [string cat $ns :: $src]\n"
"        }\n"
"        interp alias {} $src {} ${ns}::my $dst\n"
"        trace add command ${ns}::my delete [list ::oo::Helpers::Unlink $src]\n"
"    }\n"
"    return\n"
"}\n"
"::proc ::oo::Helpers::Unlink {cmd args} {\n"
"    if {[namespace which $cmd] ne {}} {\n"
"        rename $cmd {}\n"
"    }\n"
"}\n"

"::proc ::oo::DelegateName {class} {\n"
"    string cat [info object namespace $class] {:: oo ::delegate}\n"
"}\n"

"proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
"    # Create the method on the class if the caller gave arguments and body\n"
"    set argc [llength [info level 0]]\n"
"    if {$argc == 3} {\n"

Changes to tests/ooUtil.test.

297
298
299
300
301
302
303


































































































304
305
306
307
308
309
310
    set x [pqr new]
    set y [pqr create ::y]
    lappend codes [$x foo] [$x bar] $y
} -cleanup {
    parent destroy
} -result {1 1 1 123 456 ::y}



































































































# Tests that verify issues detected with the tcllib version of the code
test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
    oo::class create animal {}
    namespace eval ::ooutiltest {
	oo::class create pet { superclass animal }
    }
} -body {






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







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
    set x [pqr new]
    set y [pqr create ::y]
    lappend codes [$x foo] [$x bar] $y
} -cleanup {
    parent destroy
} -result {1 1 1 123 456 ::y}

test ooUtil-6.1 {TIP 478: classvarable} -setup {
    oo::class create parent
} -body {
    oo::class create xyz {
	superclass parent
	initialise {
	    variable x 1 y 2
	}
	method a {} {
	    classvariable x
	    incr x
	}
	method b {} {
	    classvariable y
	    incr y
	}
	method c {} {
	    classvariable x y
	    list $x $y
	}
    }
    set p [xyz new]
    set q [xyz new]
    set result [list [$p c] [$q c]]
    $p a
    $q b
    lappend result [[xyz new] c]
} -cleanup {
    parent destroy
} -result {{1 2} {1 2} {2 3}}
test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
    oo::class create parent
} -body {
    oo::class create xyz {
	superclass parent
	method a {} {
	    classvariable x(1)
	    incr x(1)
	}
    }
    set p [xyz new]
    set q [xyz new]
    list [$p a] [$q a]
} -returnCodes error -cleanup {
    parent destroy
} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
    oo::class create parent
} -body {
    oo::class create xyz {
	superclass parent
	method a {} {
	    classvariable ::x
	    incr x
	}
    }
    set p [xyz new]
    set q [xyz new]
    list [$p a] [$q a]
} -returnCodes error -cleanup {
    parent destroy
} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}

test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	method foo {} {return "in foo of [self]"}
	method Bar {} {return "in bar of [self]"}
	method Grill {} {return "in grill of [self]"}
	export eval
	constructor {} {
	    link foo
	    link {bar Bar} {grill Grill}
	}
    }
    cls create o
    o eval {list [foo] [bar] [grill]}
} -cleanup {
    parent destroy
} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
    oo::class create parent
} -body {
    oo::class create cls {
	superclass parent
	method foo {} {return "in foo of [self]"}
	constructor {cmd} {
	    link [list ::$cmd foo]
	}
    }
    cls create o pqr
    list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
} -cleanup {
    parent destroy
} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}

# Tests that verify issues detected with the tcllib version of the code
test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
    oo::class create animal {}
    namespace eval ::ooutiltest {
	oo::class create pet { superclass animal }
    }
} -body {