namespace.test

tcl是工具命令语言

} {::test_ns_2::cmd1 {cmd1: hello}}
test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} {
    namespace eval test_ns_1 {
        namespace export cmd1 cmd3
    }
    namespace eval test_ns_2 {
        namespace import -force ::test_ns_1::*
    }
    list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello]
} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}]
test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} {
    namespace eval test_ns_1 {
        namespace export
    }
} {cmd1 cmd3}
test namespace-26.7 {NamespaceExportCmd, -clear resets export list} {
    namespace eval test_ns_1 {
        namespace export -clear cmd4
    }
    namespace eval test_ns_2 {
        namespace import ::test_ns_1::*
    }
    list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]

test namespace-27.1 {NamespaceForgetCmd, no args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
    list [catch {namespace forget ::test_ns_1::xxx} msg] $msg
} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}}
test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
    namespace eval test_ns_1 {
        namespace export cmd*
        proc cmd1 {args} {return "cmd1: $args"}
        proc cmd2 {args} {return "cmd2: $args"}
    }
    namespace eval test_ns_2 {
        namespace import ::test_ns_1::*
        namespace forget ::test_ns_1::cmd1
    }
    info commands ::test_ns_2::*
} {::test_ns_2::cmd2}

test namespace-28.1 {NamespaceImportCmd, no args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace import
} {}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
    namespace import -force
} {}
test namespace-28.3 {NamespaceImportCmd, arg is imported} {
    namespace eval test_ns_1 {
        namespace export cmd2
        proc cmd1 {args} {return "cmd1: $args"}
        proc cmd2 {args} {return "cmd2: $args"}
    }
    namespace eval test_ns_2 {
        namespace import ::test_ns_1::*
        namespace forget ::test_ns_1::cmd1
    }
    info commands test_ns_2::*
} {::test_ns_2::cmd2}

test namespace-29.1 {NamespaceInscopeCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace inscope} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.2 {NamespaceInscopeCmd, bad args} {
    list [catch {namespace inscope ::} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} {
    list [catch {namespace inscope test_ns_1 {set v}} msg] $msg
} {1 {unknown namespace "test_ns_1" in inscope namespace command}}
test namespace-29.4 {NamespaceInscopeCmd, simple case} {
    namespace eval test_ns_1 {
        variable v 747
        proc cmd {args} {
            variable v
            return "[namespace current]::cmd: v=$v, args=$args"
        }
    }
    namespace inscope test_ns_1 cmd
} {::test_ns_1::cmd: v=747, args=}
test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} {
    list [namespace inscope test_ns_1 cmd x y z] \
         [namespace eval test_ns_1 [concat cmd [list x y z]]]
} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}

test namespace-30.1 {NamespaceOriginCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
    list [catch {namespace origin x y} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.3 {NamespaceOriginCmd, command not found} {
    list [catch {namespace origin fred} msg] $msg
} {1 {invalid command name "fred"}}
test namespace-30.4 {NamespaceOriginCmd, command isn't imported} {
    namespace origin set
} {::set}
test namespace-30.5 {NamespaceOriginCmd, imported command} {
    namespace eval test_ns_1 {
        namespace export cmd*
        proc cmd1 {args} {return "cmd1: $args"}
        proc cmd2 {args} {return "cmd2: $args"}
    }
    namespace eval test_ns_2 {
        namespace export *
        namespace import ::test_ns_1::*
        proc p {} {}
    }
    namespace eval test_ns_3 {
        namespace import ::test_ns_2::*
        list [namespace origin foreach] \
             [namespace origin p] \
             [namespace origin cmd1] \
             [namespace origin ::test_ns_2::cmd2]
    }
} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}

test namespace-31.1 {NamespaceParentCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace parent a b} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-31.2 {NamespaceParentCmd, no args} {
    namespace parent
} {}
test namespace-31.3 {NamespaceParentCmd, namespace specified} {
    namespace eval test_ns_1 {
        namespace eval test_ns_2 {
            namespace eval test_ns_3 {}
        }
    }
    list [namespace parent ::] \
         [namespace parent test_ns_1::test_ns_2] \
         [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}]
} {{} ::test_ns_1 ::test_ns_1}
test namespace-31.4 {NamespaceParentCmd, bad namespace specified} {
    list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg
} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}}

test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace qualifiers} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.2 {NamespaceQualifiersCmd, bad args} {
    list [catch {namespace qualifiers x y} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.3 {NamespaceQualifiersCmd, simple name} {
    namespace qualifiers foo
} {}
test namespace-32.4 {NamespaceQualifiersCmd, leading ::} {
    namespace qualifiers ::x::y::z
} {::x::y}
test namespace-32.5 {NamespaceQualifiersCmd, no leading ::} {
    namespace qualifiers a::b
} {a}
test namespace-32.6 {NamespaceQualifiersCmd, :: argument} {
    namespace qualifiers ::
} {}
test namespace-32.7 {NamespaceQualifiersCmd, odd number of :s} {
    namespace qualifiers :::::
} {}
test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} {
    namespace qualifiers foo:::
} {foo}

test namespace-33.1 {NamespaceTailCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace tail} msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-33.2 {NamespaceTailCmd, bad args} {
    list [catch {namespace tail x y} msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-33.3 {NamespaceTailCmd, simple name} {
    namespace tail foo
} {foo}
test namespace-33.4 {NamespaceTailCmd, leading ::} {
    namespace tail ::x::y::z
} {z}
test namespace-33.5 {NamespaceTailCmd, no leading ::} {
    namespace tail a::b
} {b}
test namespace-33.6 {NamespaceTailCmd, :: argument} {
    namespace tail ::
} {}
test namespace-33.7 {NamespaceTailCmd, odd number of :s} {
    namespace tail :::::
} {}
test namespace-33.8 {NamespaceTailCmd, odd number of :s} {
    namespace tail foo:::
} {}

test namespace-34.1 {NamespaceWhichCmd, bad args} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {namespace which} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.2 {NamespaceWhichCmd, bad args} {
    list [catch {namespace which -fred} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.3 {NamespaceWhichCmd, bad args} {
    list [catch {namespace which -command} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.4 {NamespaceWhichCmd, bad args} {
    list [catch {namespace which a b} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.5 {NamespaceWhichCmd, command lookup} {
    namespace eval test_ns_1 {
        namespace export cmd*
        variable v1 111
        proc cmd1 {args} {return "cmd1: $args"}
        proc cmd2 {args} {return "cmd2: $args"}
    }
    namespace eval test_ns_2 {
        namespace export *
        namespace import ::test_ns_1::*
        variable v2 222
        proc p {} {}
    }
    namespace eval test_ns_3 {
        namespace import ::test_ns_2::*
        variable v3 333
        list [namespace which -command foreach] \
             [namespace which -command p] \
             [namespace which -command cmd1] \
             [namespace which -command ::test_ns_2::cmd2] \
             [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg
    }
} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}}
test namespace-34.6 {NamespaceWhichCmd, -command is default} {
    namespace eval test_ns_3 {
        list [namespace which foreach] \
             [namespace which p] \
             [namespace which cmd1] \
             [namespace which ::test_ns_2::cmd2]
    }
} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
test namespace-34.7 {NamespaceWhichCmd, variable lookup} {
    namespace eval test_ns_3 {
        list [namespace which -variable env] \
             [namespace which -variable v3] \
             [namespace which -variable ::test_ns_2::v2] \
             [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
    }
} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}

test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_1 {
        proc p {} {
            namespace delete [namespace current]
            return [namespace current]
        }
    }
    test_ns_1::p
} {::test_ns_1}
test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} {
    namespace eval test_ns_1 {
        proc q {} {
            return [namespace current]
        }
    }
    list [test_ns_1::q] \
         [namespace delete test_ns_1] \
         [catch {test_ns_1::q} msg] $msg
} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}}

catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_1 {}
    set x "::test_ns_1"
    list [namespace parent $x] [set y $x] [namespace parent $y]
} {:: ::test_ns_1 ::}
catch {unset x}
catch {unset y}

test namespace-37.1 {SetNsNameFromAny, ns name found} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_1::test_ns_2 {}
    namespace eval test_ns_1 {
        namespace children ::test_ns_1
    }
} {::test_ns_1::test_ns_2}
test namespace-37.2 {SetNsNameFromAny, ns name not found} {
    namespace eval test_ns_1 {
        list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg
    }
} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}}

test namespace-38.1 {UpdateStringOfNsName} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    ;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name
    list [namespace eval {} {namespace current}] \
         [namespace eval {} {namespace current}]
} {:: ::}

test namespace-39.1 {NamespaceExistsCmd} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval ::test_ns_z::test_me { variable foo }
    list [namespace exists ::] \
	    [namespace exists ::bogus_namespace] \
	    [namespace exists ::test_ns_z] \
	    [namespace exists test_ns_z] \
	    [namespace exists ::test_ns_z::foo] \
	    [namespace exists ::test_ns_z::test_me] \
	    [namespace eval ::test_ns_z { namespace exists ::test_me }] \
	    [namespace eval ::test_ns_z { namespace exists test_me }] \
	    [namespace exists :::::test_ns_z]
} {1 0 1 1 0 1 0 1 1}
test namespace-39.2 {NamespaceExistsCmd error} {
    list [catch {namespace exists} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}
test namespace-39.3 {NamespaceExistsCmd error} {
    list [catch {namespace exists a b} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}

test namespace-40.1 {Ignoring namespace proc "unknown"} {
    rename unknown _unknown
    proc unknown args {return global}
    namespace eval ns {proc unknown args {return local}}
    set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]]
    rename unknown {}   
    rename _unknown unknown
    namespace delete ns
    set l
} {global global}

test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
    set res {}
    namespace eval ns {
	set res {}
	proc test {} {
	    set ::g 0
	}  
	lappend ::res [test]
	proc set {a b} {
	    ::set a [incr b]
	}
	lappend ::res [test]
    }
    namespace delete ns
    set res
} {0 1}

test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
    set res {}
    namespace eval ns {}
    proc ns::a {i} {
	variable b
	proc set args {return "New proc is called"}
	return [set b $i]
    }
    ns::a 1
    set res [ns::a 2]
    namespace delete ns
    set res
} {New proc is called}

test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
    set res {}
    namespace eval ns {
	variable b 0
    }

    proc ns::a {i} {
	variable b
	proc set args {return "New proc is called"}
	return [set b $i]
    }
    
    set res [list [ns::a 1] $ns::b]
    namespace delete ns
    set res
} {{New proc is called} 0}

# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
eval namespace delete [namespace children :: test_ns_*]
::tcltest::cleanupTests
return