# Commands covered:  upvar

 #

 # This file contains a collection of tests for one or more of the Tcl

 # built-in commands.  Sourcing this file into Tcl runs the tests and

 # generates output for errors.  No output means no errors were found.

 #

 # Copyright (c) 1991-1993 The Regents of the University of California.

 # Copyright (c) 1994 Sun Microsystems, Inc.

 # Copyright (c) 1998-1999 by Scriptics Corporation.

 #

 # See the file "license.terms" for information on usage and redistribution

 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 #

 # RCS: @(#) $Id: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $

 if {[lsearch [namespace children] ::tcltest] == -1} {

     package require tcltest

     namespace import -force ::tcltest::*

 }

 test upvar-1.1 {reading variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2}

     proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}

     p1 foo bar

 } {foo bar 22 33 abc}

 test upvar-1.2 {reading variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2}

     proc p2 {} {p3}

     proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}

     p1 foo bar

 } {foo bar 22 33 abc}

 test upvar-1.3 {reading variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2}

     proc p2 {} {p3}

     proc p3 {} {

 	upvar #1 a x1 b x2 c x3 d x4

 	set a abc

 	list $x1 $x2 $x3 $x4 $a

     }

     p1 foo bar

 } {foo bar 22 33 abc}

 test upvar-1.4 {reading variables with upvar} {

     set x1 44

     set x2 55

     proc p1 {} {p2}

     proc p2 {} {

 	upvar 2 x1 x1 x2 a

 	upvar #0 x1 b

 	set c $b

 	incr b 3

 	list $x1 $a $b

     }

     p1

 } {47 55 47}

 test upvar-1.5 {reading array elements with upvar} {

     proc p1 {} {set a(0) zeroth; set a(1) first; p2}

     proc p2 {} {upvar a(0) x; set x}

     p1

 } {zeroth}

 test upvar-2.1 {writing variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}

     proc p2 {} {

 	upvar a x1 b x2 c x3 d x4

 	set x1 14

 	set x4 88

     }

     p1 foo bar

 } {14 bar 22 88}

 test upvar-2.2 {writing variables with upvar} {

     set x1 44

     set x2 55

     proc p1 {x1 x2} {

 	upvar #0 x1 a

 	upvar x2 b

 	set a $x1

 	set b $x2

     }

     p1 newbits morebits

     list $x1 $x2

 } {newbits morebits}

 test upvar-2.3 {writing variables with upvar} {

     catch {unset x1}

     catch {unset x2}

     proc p1 {x1 x2} {

 	upvar #0 x1 a

 	upvar x2 b

 	set a $x1

 	set b $x2

     }

     p1 newbits morebits

     list [catch {set x1} msg] $msg [catch {set x2} msg] $msg

 } {0 newbits 0 morebits}

 test upvar-2.4 {writing array elements with upvar} {

     proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)}

     proc p2 {} {upvar a(0) x; set x xyzzy}

     p1

 } {xyzzy xyzzy}

 test upvar-3.1 {unsetting variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}

     proc p2 {} {

 	upvar 1 a x1 d x2

 	unset x1 x2

     }

     p1 foo bar

 } {b c}

 test upvar-3.2 {unsetting variables with upvar} {

     proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}

     proc p2 {} {

 	upvar 1 a x1 d x2

 	unset x1 x2

 	set x2 28

     }

     p1 foo bar

 } {b c d}

 test upvar-3.3 {unsetting variables with upvar} {

     set x1 44

     set x2 55

     proc p1 {} {p2}

     proc p2 {} {

 	upvar 2 x1 a

 	upvar #0 x2 b

 	unset a b

     }

     p1

     list [info exists x1] [info exists x2]

 } {0 0}

 test upvar-3.4 {unsetting variables with upvar} {

     set x1 44

     set x2 55

     proc p1 {} {

 	upvar x1 a x2 b

 	unset a b

 	set b 118

     }

     p1

     list [info exists x1] [catch {set x2} msg] $msg

 } {0 0 118}

 test upvar-3.5 {unsetting array elements with upvar} {

     proc p1 {} {

 	set a(0) zeroth

 	set a(1) first

 	set a(2) second

 	p2

 	array names a

     }

     proc p2 {} {upvar a(0) x; unset x}

     p1

 } {1 2}

 test upvar-3.6 {unsetting then resetting array elements with upvar} {

     proc p1 {} {

 	set a(0) zeroth

 	set a(1) first

 	set a(2) second

 	p2

 	list [array names a] [catch {set a(0)} msg] $msg

     }

     proc p2 {} {upvar a(0) x; unset x; set x 12345}

     p1

 } {{0 1 2} 0 12345}

 test upvar-4.1 {nested upvars} {

     set x1 88

     proc p1 {a b} {set c 22; set d 33; p2}

     proc p2 {} {global x1; upvar c x2; p3}

     proc p3 {} {

 	upvar x1 a x2 b

 	list $a $b

     }

     p1 14 15

 } {88 22}

 test upvar-4.2 {nested upvars} {

     set x1 88

     proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}

     proc p2 {} {global x1; upvar c x2; p3}

     proc p3 {} {

 	upvar x1 a x2 b

 	set a foo

 	set b bar

     }

     list [p1 14 15] $x1

 } {{14 15 bar 33} foo}

 proc tproc {args} {global x; set x [list $args [uplevel info vars]]}

 test upvar-5.1 {traces involving upvars} {

     proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}

     proc p2 {} {upvar c x1; set x1 22}

     set x ---

     p1 foo bar

     set x

 } {{x1 {} w} x1}

 test upvar-5.2 {traces involving upvars} {

     proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}

     proc p2 {} {upvar c x1; set x1}

     set x ---

     p1 foo bar

     set x

 } {{x1 {} r} x1}

 test upvar-5.3 {traces involving upvars} {

     proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2}

     proc p2 {} {upvar c x1; unset x1}

     set x ---

     p1 foo bar

     set x

 } {{x1 {} u} x1}

 test upvar-6.1 {retargeting an upvar} {

     proc p1 {} {

 	set a(0) zeroth

 	set a(1) first

 	set a(2) second

 	p2

     }

     proc p2 {} {

 	upvar a x

 	set result {}

 	foreach i [array names x] {

 	    upvar a($i) x

 	    lappend result $x

 	}

 	lsort $result

     }

     p1

 } {first second zeroth}

 test upvar-6.2 {retargeting an upvar} {

     set x 44

     set y abcde

     proc p1 {} {

 	global x

 	set result $x

 	upvar y x

 	lappend result $x

     }

     p1

 } {44 abcde}

 test upvar-6.3 {retargeting an upvar} {

     set x 44

     set y abcde

     proc p1 {} {

 	upvar y x

 	lappend result $x

 	global x

 	lappend result $x

     }

     p1

 } {abcde 44}

 test upvar-7.1 {upvar to same level} {

     set x 44

     set y 55

     catch {unset uv}

     upvar #0 x uv

     set uv abc

     upvar 0 y uv

     set uv xyzzy

     list $x $y

 } {abc xyzzy}

 test upvar-7.2 {upvar to same level} {

     set x 1234

     set y 4567

     proc p1 {x y} {

 	upvar 0 x uv

 	set uv $y

 	return "$x $y"

     }

     p1 44 89

 } {89 89}

 test upvar-7.3 {upvar to same level} {

     set x 1234

     set y 4567

     proc p1 {x y} {

 	upvar #1 x uv

 	set uv $y

 	return "$x $y"

     }

     p1 xyz abc

 } {abc abc}

 test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} {

     proc tt {} {upvar #1 toto loc;  return $loc}

     list [catch tt msg] $msg

 } {1 {can't read "loc": no such variable}}

 test upvar-7.5 {potential memory leak when deleting variable table} {

     proc leak {} {

 	array set foo {1 2 3 4}

 	upvar 0 foo(1) bar

     }

     leak

 } {}

 test upvar-8.1 {errors in upvar command} {

     list [catch upvar msg] $msg

 } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}

 test upvar-8.2 {errors in upvar command} {

     list [catch {upvar 1} msg] $msg

 } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}

 test upvar-8.3 {errors in upvar command} {

     proc p1 {} {upvar a b c}

     list [catch p1 msg] $msg

 } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}

 test upvar-8.4 {errors in upvar command} {

     proc p1 {} {upvar 0 b b}

     list [catch p1 msg] $msg

 } {1 {can't upvar from variable to itself}}

 test upvar-8.5 {errors in upvar command} {

     proc p1 {} {upvar 0 a b; upvar 0 b a}

     list [catch p1 msg] $msg

 } {1 {can't upvar from variable to itself}}

 test upvar-8.6 {errors in upvar command} {

     proc p1 {} {set a 33; upvar b a}

     list [catch p1 msg] $msg

 } {1 {variable "a" already exists}}

 test upvar-8.7 {errors in upvar command} {

     proc p1 {} {trace variable a w foo; upvar b a}

     list [catch p1 msg] $msg

 } {1 {variable "a" has traces: can't use for upvar}}

 test upvar-8.8 {create nested array with upvar} {

     proc p1 {} {upvar x(a) b; set b(2) 44}

     catch {unset x}

     list [catch p1 msg] $msg

 } {1 {can't set "b(2)": variable isn't array}}

 test upvar-8.9 {upvar won't create namespace variable that refers to procedure variable} {

     catch {eval namespace delete [namespace children :: test_ns_*]}

     catch {rename MakeLink ""}

     namespace eval ::test_ns_1 {}

     proc MakeLink {a} {

         namespace eval ::test_ns_1 {

 	    upvar a a

         }

         unset ::test_ns_1::a

     }

     list [catch {MakeLink 1} msg] $msg

 } {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}

 test upvar-8.10 {upvar will create element alias for new array element} {

     catch {unset upvarArray}

     array set upvarArray {}

     catch {upvar 0 upvarArray(elem) upvarArrayElemAlias}

 } {0}

 if {[info commands testupvar] != {}} {

     test upvar-9.1 {Tcl_UpVar2 procedure} {

 	list [catch {testupvar xyz a {} x global} msg] $msg

     } {1 {bad level "xyz"}}

     test upvar-9.2 {Tcl_UpVar2 procedure} {

 	catch {unset a}

 	catch {unset x}

 	set a 44

 	list [catch {testupvar #0 a 1 x global} msg] $msg

     } {1 {can't access "a(1)": variable isn't array}}

     test upvar-9.3 {Tcl_UpVar2 procedure} {

 	proc foo {} {

 	    testupvar 1 a {} x local

 	    set x

 	}

 	catch {unset a}

 	catch {unset x}

 	set a 44

 	foo

     } {44}

     test upvar-9.4 {Tcl_UpVar2 procedure} {

 	proc foo {} {

 	    testupvar 1 a {} _up_ global

 	    list [catch {set x} msg] $msg

 	}

 	catch {unset a}

 	catch {unset _up_}

 	set a 44

 	concat [foo] $_up_

     } {1 {can't read "x": no such variable} 44}

     test upvar-9.5 {Tcl_UpVar2 procedure} {

 	proc foo {} {

 	    testupvar 1 a b x local

 	    set x

 	}

 	catch {unset a}

 	catch {unset x}

 	set a(b) 1234

 	foo

     } {1234}

     test upvar-9.6 {Tcl_UpVar procedure} {

 	proc foo {} {

 	    testupvar 1 a x local

 	    set x

 	}

 	catch {unset a}

 	catch {unset x}

 	set a xyzzy

 	foo

     } {xyzzy}

     test upvar-9.7 {Tcl_UpVar procedure} {

 	proc foo {} {

 	    testupvar #0 a(b) x local

 	    set x

 	}

 	catch {unset a}

 	catch {unset x}

 	set a(b) 1234

 	foo

     } {1234}

 }

 catch {unset a}

 # cleanup

 ::tcltest::cleanupTests

 return