#
# Tests for code/scope commands
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
# ----------------------------------------------------------------------
#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl

# ----------------------------------------------------------------------
#  Syntax of the "scope" command
# ----------------------------------------------------------------------
test scope-1.1 {scope command takes one argument} {
    list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg
} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}}

test scope-1.2 {argument to scope command must be a variable} {
    variable test_scope_var 0
    list [catch {itcl::scope xyzzy} msg] $msg \
         [catch {itcl::scope test_scope_var} msg] $msg
} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var}

test scope-1.3 {if variable is already fully qualified, scope does nothing} {
    list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var]
} {::xyzzy ::test_scope_var}

test scope-1.4 {scope command returns fully qualified name} {
    namespace eval test_scope_ns {
        namespace eval child {
            variable v1 0
            itcl::scope v1
        }
    }
} {::test_scope_ns::child::v1}

namespace delete test_scope_ns
unset test_scope_var

# ----------------------------------------------------------------------
#  Syntax of the "code" command
# ----------------------------------------------------------------------
test scope-2.1 {code command takes at least one argument} {
    list [catch {itcl::code} msg] $msg
} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}}

test scope-2.2 {code command with one argument} {
    itcl::code arg1
} {namespace inscope :: arg1}

test scope-2.3 {code command with many arguments} {
    list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4]
} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}}

test scope-2.4 {code command appends arguments as list elements} {
    list [itcl::code "foo bar"] \
         [itcl::code "foo bar" "hello, world!" "one, two, three"]
} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}}

test scope-2.5 {code command inside code command} {
    itcl::code [itcl::code arg1 arg2] arg3
} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}}

test scope-2.6 {code command returns fully qualified names} {
    namespace eval test_scope_ns {
        namespace eval child {
            itcl::code foo bar baz
        }
    }
} {namespace inscope ::test_scope_ns::child {foo bar baz}}

test scope-2.7 {code command lets you specify a namespace} {
    list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \
         [catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg
} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}}

test scope-2.8 {last namespace wins} {
    itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1
} {namespace inscope ::test_scope_ns arg1}

test scope-2.9 {"--" terminates switches} {
    list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \
         [catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg
} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}}

namespace delete test_scope_ns

# ----------------------------------------------------------------------
#  Test code/scope commands in a class
# ----------------------------------------------------------------------
test scope-3.1 {define simple classes with things to export} {
    itcl::class test_scope {
        private variable priv "private-value"
        protected variable prov "protected-value"
        public variable pubv "public-value"

        private common pric "private-common-value"
        protected common proc "protected-common-value"
        public common pubc "public-common-value"

        variable varray
        common carray

        method mcontext {args} {
            return [eval $args]
        }
        proc pcontext {args} {
            return [eval $args]
        }

        private method prim {args} {
            return "prim: $args"
        }
        protected method prom {args} {
            return "prom: $args"
        }
        public method pubm {args} {
            return "pubm: $args"
        }
    }
    test_scope #auto
} {test_scope0}

test scope-3.2 {code command captures only class context} {
    list [test_scope0 mcontext itcl::code arg1 arg2] \
         [test_scope::pcontext itcl::code arg1 arg2]
} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}}

test scope-3.3 {scope command captures class and object context} -body {
    list [test_scope0 mcontext itcl::scope priv] \
         [test_scope::pcontext itcl::scope pric]
} -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::test_scope::pric}

test scope-3.4 {scope command must recognize variable} {
    list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg
} {1 {variable "xyzzy" not found in class "::test_scope"}}

test scope-3.5 {scope command provides access to instance variables} {
    set result ""
    foreach vname {priv prov pubv} {
        lappend result [test_scope0 info variable $vname]
        set var [test_scope0 mcontext itcl::scope $vname]
        set $var "$vname-new"
        lappend result [test_scope0 info variable $vname]
    }
    set result
} {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}}

test scope-3.6 {scope command provides access to common variables} {
    set result ""
    foreach vname {pric proc pubc} {
        lappend result [test_scope0 info variable $vname]
        set var [test_scope0 mcontext itcl::scope $vname]
        set $var "$vname-new"
        lappend result [test_scope0 info variable $vname]
    }
    set result
} {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}}

test scope-3.7 {code command provides access to methods} {
    set result ""
    foreach mname {prim prom pubm} {
        set cmd [test_scope0 mcontext eval itcl::code \$this $mname]
        lappend result $cmd [uplevel 0 $cmd 1 2 3]
    }
    set result
} {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}}

test scope-3.8 {scope command allows access to slots in an array} -body {
    test_scope0 mcontext set varray(0) "defined"
    test_scope::pcontext set carray(0) "defined"
    list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \
         [catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \
         [catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \
         [catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg
} -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::test_scope::carray(1)}

itcl::delete class test_scope

# ----------------------------------------------------------------------
#  Test code/scope commands in a namespace
# ----------------------------------------------------------------------
test scope-4.1 {define simple namespace with things to export} {
    namespace eval test_scope_ns {
        variable array
        proc pcontext {args} {
            return [eval $args]
        }
    }
    namespace children :: ::test_scope_ns
} {::test_scope_ns}

test scope-4.2 {scope command allows access to slots in an array} {
    test_scope_ns::pcontext set array(0) "defined"
    list [catch {test_scope_ns::pcontext itcl::scope array(0)} msg] $msg \
         [catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg
} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}

namespace delete test_scope_ns

test scope-5.0 {Bug e5f529da75} -setup {
    itcl::class B {
	common c
	method v {} {itcl::scope c}
    }
    itcl::class D {
	inherit B
	method v {} {itcl::scope c}
    }
    B b
    D d
} -body {
    string equal [b v] [d v]
} -cleanup {
    itcl::delete class B
} -result 1

::tcltest::cleanupTests
return