basic.test

来自「tcl是工具命令语言」· TEST 代码 · 共 657 行 · 第 1/2 页

# This file contains tests for the tclBasic.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
# and trace.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 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: basic.test,v 1.25 2003/02/16 01:36:32 msofer Exp $
#

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]

# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {unset x}

test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            proc p {} {
                return [namespace current]
            }
        }
    }
    list [interp eval test_interp {test_ns_basic::p}] \
         [interp delete test_interp]
} {::test_ns_basic {}}

test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
} {}

test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
} {}

test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
} {}

test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}

test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            namespace export p
            proc p {} {
                return [namespace current]
            }
        }
        namespace eval test_ns_2 {
            namespace import ::test_ns_basic::p
            variable v 27
            proc q {} {
                variable v
                return "[p] $v"
            }
        }
    }
    list [interp eval test_interp {test_ns_2::q}] \
         [interp eval test_interp {namespace delete ::}] \
         [catch {interp eval test_interp {set a 123}} msg] $msg \
         [interp delete test_interp]
} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}

test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        proc p {} {
            return 27
        }
    }
    interp alias {} localP test_interp p
    list [interp eval test_interp {p}] \
         [localP] \
         [test_interp hide p] \
         [catch {localP} msg] $msg \
         [interp delete test_interp] \
         [catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}

# NB: More tests about hide/expose are found in interp.test

test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            proc p {} {
                return [namespace current]
            }
        }
    }
    list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
	 [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
         [interp delete test_interp]
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}

test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
    catch {namespace delete test_ns_basic}
    catch {rename cmd ""}
    proc cmd {} {   ;# note that this is global
        return [namespace current]
    }
    namespace eval test_ns_basic {
        proc hideCmd {} {
            interp hide {} cmd
        }
        proc exposeCmd {} {
            interp expose {} cmd
        }
        proc callCmd {} {
            cmd
        }
    }
    list [test_ns_basic::callCmd] \
         [test_ns_basic::hideCmd] \
         [catch {cmd} msg] $msg \
         [test_ns_basic::exposeCmd] \
         [test_ns_basic::callCmd] \
         [namespace delete test_ns_basic]
} {:: {} 1 {invalid command name "cmd"} {} :: {}}

test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
    catch {namespace delete test_ns_basic}
    catch {rename cmd ""}
    proc cmd {} {   ;# note that this is global
        return [namespace current]
    }
    namespace eval test_ns_basic {
        proc hideCmd {} {
            interp hide {} cmd
        }
        proc exposeCmdFailing {} {
            interp expose {} cmd ::test_ns_basic::newCmd
        }
        proc exposeCmdWorkAround {} {
            interp expose {} cmd;
	    rename cmd ::test_ns_basic::newCmd;
        }
        proc callCmd {} {
            cmd
        }
    }
    list [test_ns_basic::callCmd] \
         [test_ns_basic::hideCmd] \
         [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
         [test_ns_basic::exposeCmdWorkAround] \
         [test_ns_basic::newCmd] \
         [namespace delete test_ns_basic]
} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
    catch {rename p ""}
    catch {rename cmd ""}
    proc p {} {
        cmd
    }
    proc cmd {} {
        return 42
    }
    list [p] \
         [interp hide {} cmd] \
         [proc cmd {} {return Hello}] \
         [cmd] \
         [rename cmd ""] \
         [interp expose {} cmd] \
         [p]
} {42 {} {} Hello {} {} 42}

test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [testcreatecommand create] \
	 [test_ns_basic::createdcommand] \
	 [testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename value:at: ""}
    list [testcreatecommand create2] \
	 [value:at:] \
	 [testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}

test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic {}
    proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist
        return [namespace current]
    }
    list [test_ns_basic::cmd] \
         [namespace delete test_ns_basic]
} {::test_ns_basic {}}

test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}

test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
} {}

test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename cmd ""}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    list [test_ns_basic::p] \
         [rename test_ns_basic::p test_ns_basic::q] \
         [test_ns_basic::q] 
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    list [info commands test_ns_basic::*] \
         [rename test_ns_basic::p ""] \
         [info commands test_ns_basic::*]
} {::test_ns_basic::p {} {}}
test basic-18.4 {TclRenameCommand, bad new name} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    rename test_ns_basic::p :::george::martha
} {}
test basic-18.5 {TclRenameCommand, new name must not already exist} {
    namespace eval test_ns_basic {
        proc q {} {
            return 42
        }
    }
    list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
} {1 {can't rename to ":::george::martha": command already exists}}
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename p ""}
    catch {rename q ""}
    proc p {} {
        return "p in [namespace current]"
    }
    proc q {} {
        return "q in [namespace current]"
    }
    namespace eval test_ns_basic {
        proc callP {} {
            p
        }
    }
    list [test_ns_basic::callP] \
         [rename q test_ns_basic::p] \
         [test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}

test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}

test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
    catch {eval namespace delete [namespace children :: test_ns_*]}
    catch {rename p ""}
    catch {rename q ""}
    catch {unset x}
    set x [namespace eval test_ns_basic::test_ns_basic2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create p
    }]
    list [testcmdtoken name $x] \
         [rename ::p q] \
         [testcmdtoken name $x]
} {{p ::p} {} {q ::q}}
test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
    catch {rename q ""}
    set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
    list [testcmdtoken name $x] \
         [rename test_ns_basic::test_ns_basic2::p q] \
         [testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}

test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {