Tcl Source Code

Artifact 9e23cf82a67734ba3a3aaadc0dc145ae908b6294:

proc dump {{text {}}} {
    set text [uplevel 1 [list subst $text]]
    set l [expr {[info level] -1}]
    if {$text eq {}} {
	set text [info level $l]
    }
    puts "$l: $text"
}
# proc dump args {}
set v "global level"
oo::class create foo { # like connection
    method alpha {} {  # like connections 'tables' method
	dump
	upvar 1 v w
	dump {inside foo's alpha, v resolves to $w}
	set v "foo's method alpha"
	dump {foo's alpha is calling [self] bravo - v should resolve at global level}
	set result [uplevel 1 [list [self] bravo]]
	dump {exiting from foo's alpha}
	return $result
    }
    method bravo {} {  # like connections 'foreach' method
	dump
	upvar 1 v w
	dump {inside foo's bravo, v resolves to $w}
	set v "foo's method bravo"
	dump {foo's bravo is calling charlie to create barney}
	set barney [my charlie ::barney]
	dump {foo's bravo is calling bravo on $barney}
	dump {v should resolve at global scope there}
	set result [uplevel 1 [list $barney bravo]]
	dump {exiting from foo's bravo}
	return $result
    }
    method charlie {name} {  # like tdbc prepare
	dump
	set v "foo's method charlie"
	dump {tailcalling bar's constructor}
        tailcall ::bar create $name
    }
}
oo::class create bar { # like statement
    method  bravo {} {   # like statement foreach method
	dump
	upvar 1 v w
	dump {inside bar's bravo, v is resolving to $w}
	set v "bar's method bravo"
	dump {calling delta to construct betty - v should resolve global there}
	uplevel 1 [list [self] delta ::betty]
	dump {exiting from bar's bravo}
	return [::betty whathappened]
    }
    method delta {name} {    # like statement execute method
	dump
	upvar 1 v w
	dump {inside bar's delta, v is resolving to $w}
	set v "bar's method delta"
	dump {tailcalling to construct $name as instance of grill}
	dump {v should resolve at global level in grill's constructor}
	dump {grill's constructor should run at level [info level]}
	tailcall grill create $name
    }
}
oo::class create grill {
    variable resolution
    constructor {} {
	dump
	upvar 1 v w
	dump "in grill's constructor, v resolves to $w"
	set resolution $w
    }
    method whathappened {} {
	return $resolution
    }
}
foo create fred
set result [fred alpha]
if {$result ne "global level"} {
    puts "v should have been found at global level but was found in $result"
}