diff options
author | Steve Bennett <steveb@workware.net.au> | 2011-12-01 17:25:36 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2011-12-12 13:44:16 +1000 |
commit | 7f383c6726fd71c23d622753152faf749124ca22 (patch) | |
tree | 32cf6285c78d54e4931d0558e895c0d8b077ce17 | |
parent | 1f0d4b7361480fd029dbf5b5462d3a6a0068e5d0 (diff) | |
download | jimtcl-7f383c6726fd71c23d622753152faf749124ca22.zip jimtcl-7f383c6726fd71c23d622753152faf749124ca22.tar.gz jimtcl-7f383c6726fd71c23d622753152faf749124ca22.tar.bz2 |
Add support for lightweight namespaces
See README.namespaces
Signed-off-by: Steve Bennett <steveb@workware.net.au>
-rw-r--r-- | README.namespaces | 191 | ||||
-rw-r--r-- | auto.def | 4 | ||||
-rw-r--r-- | examples/dns.tcl | 63 | ||||
-rw-r--r-- | jim-namespace.c | 333 | ||||
-rw-r--r-- | jim.c | 365 | ||||
-rw-r--r-- | jim.h | 11 | ||||
-rw-r--r-- | nshelper.tcl | 124 | ||||
-rw-r--r-- | tests/alias.test | 2 | ||||
-rw-r--r-- | tests/namespace.test | 493 | ||||
-rw-r--r-- | utf8.h | 2 |
10 files changed, 1475 insertions, 113 deletions
diff --git a/README.namespaces b/README.namespaces new file mode 100644 index 0000000..e08d68e --- /dev/null +++ b/README.namespaces @@ -0,0 +1,191 @@ +Lightweight Namespaces for Jim Tcl +================================== + +There are two broad requirements for namespace support in Jim Tcl. + +1. To allow code from multiple sources while reducing the chance of name clashes +2. To simplify porting existing Tcl code which uses namespaces + +This proposal addresses both of these requirements, with the following +additional requirements imposed by Jim Tcl. + +3. Support for namespaces should be optional, with the space and time overhead + when namespaces are disabled as close to zero as possible. +4. The implementation should be small and reasonably efficient. + +To further expand on requirement (2), the goal is not to be able to run +any Tcl scripts using namespaces with no changes. Rather, scripts +which use namespaces in a straightforward manner, should be easily +ported with changes which are compatible with Tcl. + +Implicit namespaces +------------------- +Rather than supporting explicit namespaces as Tcl does, Jim Tcl +supports implicit namespaces. Any procedure or variable which +is defined with a name containing ::, is implicitly scoped within +a namespace. + +For example, the following procedure and variable are created +in the namespace 'test' + +proc ::test::myproc {} { + puts "I am in namespace [namespace current]" +} +set ::test::myvar 3 + +This approach allows much of the existing variable and command +resolution machinery to be used with little change. It also means +that it is possible to simply define a namespace-scoped variable +or procedure without first creating the namespace, and similarly, +namespaces "disappear" when all variables and procedures defined +with the namespace scope are deleted. + +Namespaces, procedures and call frames +-------------------------------------- +When namespace support is enabled (at build time), each procedure has an associated +namespace (based on the procedure name). When the procedure is evaluated, +the namespace for the created call frame is set to the namespace associated +with the procedure. + +Command resolution is based on the namespace of the current call frame. +An unscoped command name will first be looked up in the current namespace, +and then in the global namespace. + +This also means that commands which do not create a call frame (such as commands +implemented in C) do not have an associated namespace. + +Similarly to Tcl, namespace eval introduces a temporary, anonymous +call frame with the associated namespace. For example, the following +will return "::test,1". + +namespace eval test { + puts [namespace current],[info level] +} + +Variable resolution +------------------- +The variable command in Jim Tcl has the same syntax as Tcl, but is closer in behaviour to the global command. +The variable command creates a link from a local variable to a namespace variable, possibly initialising it. + +For example, the following procedure uses 'variable' to initialse and access myvar. + +proc ::test::myproc {} { + variable myvar 4 + incr myvar +} + +Note that there is no automatic resolution of namespace variables. +For example, the following will *not* work. + +namespace eval ::test { + variable myvar 4 +} +namespace eval ::test { + # This will increment a local variable, not ::test::myvar + incr myvar +} + +And similarly, the following will only access local variables + +set x 3 +namespace eval ::test { + # This will incremement a local variable, not ::x + incr x + # This will also increment a local variable + incr abc::def +} + +In the same way that variable resolution does not "fall back" to +global variables, it also does not "fall back" to namespace variables. + +This approach allows name resolution to be simpler and more efficient +since it uses the same variable linking mechanism as upvar/global +and it allows namespaces to be implicit. It also solves the "creative +writing" problem where a variable may be created in an unintentional +scope. + +The namespace command +--------------------- +Currently, the following namespace commands are supported. + +* current - returns the current, fully-qualified namespace +* eval - evaluates a script in a namespace (introduces a call frame) +* qualifiers, tail, parent - note that these do not check for existence +* code, inscope - implemented +* delete - deletes all variables and commands with the namespace prefix +* which - implemented +* upvar - implemented + +namespace children, exists, path +-------------------------------- +With implicit namespaces, the namespace exists and namespace children commands +are expensive to implement and are of limited use. Checking the existence +of a namespace can be better done by checking for the existence of a known procedure +or variable in the namespace. + +Command resolution is always done by first looking in the namespace and then +at the global scope, so namespace path is not required. + +namespace ensemble +------------------ +The namespace ensemble command is not currently supported. A future version +of Jim Tcl will have a general-purpose ensemble creation and manipulation +mechanism and namespace ensemble will be implemented in terms of that mechanism. + +namespace import, export, forget, origin +---------------------------------------- +Since Jim Tcl namespaces are implicit, there is no location to store export patterns. +Therefore the namespace export command is a dummy command which does nothing. +All procedures in a namespace are considered to be exported. + +The namespace import command works by creating aliases to the target namespace +procedures. + +namespace forget is not implemented. + +namespace origin understands aliases created by namespace import +and can return the original command. + +namespace unknown +----------------- +If an undefined command is invoked, the "unknown" command is invoked. +The same namespace resolution rules apply for the unknown command. +This means that in the following example, test::unknown will be invoked +for the missing command rather than the global ::unknown. + +proc unknown {args} { + puts "global unknown" +} + +proc test::unknown {args} { + puts "test unknown" +} + +namespace eval test { + bogus +} + +This approach requires no special support and provides enough flexibility that +the namespace unknown command is not implemented. + +Porting namespace code from Tcl to Jim Tcl +------------------------------------------ +For most code, the following changes will be sufficient to port code. + +1. Canonicalise namespace names. For example, ::ns:: should be written + as ::ns or ns as appropriate, and excess colons should be removed. + For example ::ns:::blah should be written as ::ns::blah + (Note that the only "excess colon" case supported is ::::abc + in order to support [namespace current]::abc in the global namespace) + +2. The variable command should be used within namespace eval to link + to namespace variables, and access to variables in other namespaces + should be fully qualified + +Changes in the core Jim Tcl +--------------------------- +Previously Jim Tcl performed no scoping of command names. i.e. The +::format command was considered different from the format command. + +Even if namespace support is disabled, the command resolution will +recognised global scoping of commands and treat these as identical. @@ -197,6 +197,8 @@ dict set extdb attrs { history {} load { static } mk { cpp optional } + namespace { static } + nshelper { tcl optional } oo { tcl } pack {} package { static } @@ -226,10 +228,12 @@ dict set extdb info { glob { dep readdir } load { check {[have-feature dlopen-compat] || [cc-check-function-in-lib dlopen dl]} libdep lib_dlopen } mk { check {[check-metakit]} libdep lib_mk } + namespace { dep nshelper } posix { check {[have-feature waitpid]} } readdir { check {[have-feature opendir]} } readline { check {[cc-check-function-in-lib readline readline]} } rlprompt { dep readline } + tree { dep oo } sdl { check {[cc-check-function-in-lib SDL_SetVideoMode SDL] && [cc-check-function-in-lib rectangleRGBA SDL_gfx]} libdep {lib_SDL_SetVideoMode lib_rectangleRGBA} } diff --git a/examples/dns.tcl b/examples/dns.tcl index a40d44a..8146027 100644 --- a/examples/dns.tcl +++ b/examples/dns.tcl @@ -42,12 +42,7 @@ # $Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $ package require binary - -# Poor-man's variable for Jim Tcl -# Links a global variable, ::ns::var to a local variable, var -proc variable {ns var} { - catch {uplevel 1 [list upvar #0 ${ns}::$var $var]} -} +package require namespace set dns::version 1.3.3 set dns::rcsid {$Id: dns.tcl,v 1.36 2008/11/22 12:28:54 mic42 Exp $} @@ -81,8 +76,8 @@ if {![info exists dns::uid]} { # to be set. With no options, returns a list of all current settings. # proc dns::configure {args} { - variable dns options - variable dns log + variable options + variable log if {[llength $args] < 1} { set r {} @@ -169,9 +164,9 @@ proc dns::configure {args} { # to be used to obtain any further information about this query. # proc dns::resolve {query args} { - variable dns uid - variable dns options - variable dns log + variable uid + variable options + variable log # get a guaranteed unique and non-present token id. set id [incr uid] @@ -427,7 +422,7 @@ proc dns::dump {args} { } # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state set result {} @@ -467,11 +462,11 @@ proc dns::DumpMessage {data} { # proc dns::BuildMessage {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state - variable dns types - variable dns classes - variable dns options + variable types + variable classes + variable options if {! [info exists types($state(-type))] } { return -code error "invalid DNS query type" @@ -564,8 +559,8 @@ proc dns::PackString {text} { # eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com} # proc dns::PackRecord {args} { - variable dns types - variable dns classes + variable types + variable classes array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""} array set rr $args set data [dns::PackName $rr(name)] @@ -626,7 +621,7 @@ proc dns::PackRecord {args} { # proc dns::TcpTransmit {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state # setup the timeout @@ -646,7 +641,7 @@ proc dns::TcpTransmit {token} { } proc dns::TcpConnected {token s} { - variable dns $token + variable $token upvar 0 $token state fileevent $s writable {} @@ -681,7 +676,7 @@ proc dns::TcpConnected {token s} { # proc dns::UdpTransmit {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state # setup the timeout @@ -710,7 +705,7 @@ proc dns::UdpTransmit {token} { # proc dns::Finish {token {errormsg ""}} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state global errorInfo errorCode @@ -740,7 +735,7 @@ proc dns::Finish {token {errormsg ""}} { # proc dns::Eof {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state set state(status) eof dns::Finish $token @@ -753,7 +748,7 @@ proc dns::Eof {token} { # proc dns::Receive {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state binary scan $state(reply) SS id flags @@ -781,9 +776,9 @@ proc dns::Receive {token} { # file event handler for tcp socket. Wait for the reply data. # proc dns::TcpEvent {token} { - variable dns log + variable log # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state set s $state(sock) @@ -838,7 +833,7 @@ proc dns::TcpEvent {token} { # file event handler for udp sockets. proc dns::UdpEvent {token} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state set s $state(sock) @@ -859,7 +854,7 @@ proc dns::UdpEvent {token} { proc dns::Flags {token {varname {}}} { # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state if {$varname != {}} { @@ -888,9 +883,9 @@ proc dns::Flags {token {varname {}}} { # Decode a DNS packet (either query or response). # proc dns::Decode {token args} { - variable dns log + variable log # FRINK: nocheck - variable dns $token + variable $token upvar 0 $token state array set opts {-rdata 0 -query 0} @@ -988,8 +983,8 @@ proc dns::KeyOf {&array value {default {}}} { # 12 of a message but may be of variable length. # proc dns::ReadQuestion {nitems data indexvar} { - variable dns types - variable dns classes + variable types + variable classes upvar $indexvar index set result {} @@ -1017,8 +1012,8 @@ proc dns::ReadQuestion {nitems data indexvar} { # Read an answer section from a DNS message. # proc dns::ReadAnswer {nitems data indexvar {raw 0}} { - variable dns types - variable dns classes + variable types + variable classes upvar $indexvar index set result {} diff --git a/jim-namespace.c b/jim-namespace.c new file mode 100644 index 0000000..9b606c7 --- /dev/null +++ b/jim-namespace.c @@ -0,0 +1,333 @@ +/* + * Support for namespaces in jim + * + * (c) 2011 Steve Bennett <steveb@workware.net.au> + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials + * provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, + * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + * JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * The views and conclusions contained in the software and documentation + * are those of the authors and should not be interpreted as representing + * official policies, either expressed or implied, of the Jim Tcl Project. + * + * Based on code originally from Tcl 6.7: + * + * Copyright 1987-1991 Regents of the University of California + * Permission to use, copy, modify, and distribute this + * software and its documentation for any purpose and without + * fee is hereby granted, provided that the above copyright + * notice appear in all copies. The University of California + * makes no representations about the suitability of this + * software for any purpose. It is provided "as is" without + * express or implied warranty. + */ + +#include <limits.h> +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <assert.h> + +#include "jim.h" +#include "jimautoconf.h" +#include "jim-subcmd.h" + +/* ----------------------------------------------------------------------------- + * Namespace support + * ---------------------------------------------------------------------------*/ + +/** + * nsObj is a canonical namespace name (.e.g. "" for root, "abc" for ::abc) + * + * The given name is appended to the namespace name to produce a complete canonical name. + * + * e.g. "" "abc" => abc + * "" "::abc" => abc + * "" "abc::def" => abc::def + * "abc" "def" => abc::def + * "abc" "::def" => def + * + */ +Jim_Obj *JimCanonicalNamespace(Jim_Interp *interp, Jim_Obj *nsObj, Jim_Obj *nameObj) +{ + Jim_Obj *objPtr; + const char *name = Jim_String(nameObj); + assert(nameObj->refCount != 0); + assert(nsObj->refCount != 0); + if (name[0] == ':' && name[1] == ':') { + /* Absolute namespace */ + while (*++name == ':') { + } + return Jim_NewStringObj(interp, name, -1); + } + if (Jim_Length(nsObj) == 0) { + /* Relative to the global namespace */ + return nameObj; + } + /* Relative to non-global namespace */ + objPtr = Jim_DuplicateObj(interp, nsObj); + Jim_AppendString(interp, objPtr, "::", 2); + Jim_AppendObj(interp, objPtr, nameObj); + return objPtr; +} + +int Jim_CreateNamespaceVariable(Jim_Interp *interp, Jim_Obj *varNameObj, Jim_Obj *targetNameObj) +{ + int rc; + Jim_IncrRefCount(varNameObj); + + /* push non-namespace vars if in namespace eval? */ + rc = Jim_SetVariableLink(interp, varNameObj, targetNameObj, interp->topFramePtr); + + Jim_DecrRefCount(interp, varNameObj); + + return rc; +} + +/** + * Returns the parent of the given namespace. + * + * ::bob::tom => ::bob + * bob::tom => bob + * ::bob => :: + * bob => "" + * :: => "" + * "" => "" + */ +Jim_Obj *Jim_NamespaceQualifiers(Jim_Interp *interp, Jim_Obj *ns) +{ + const char *name = Jim_String(ns); + const char *pt = strrchr(name, ':'); + if (pt && pt != name && pt[-1] == ':') { + return Jim_NewStringObj(interp, name, pt - name - 1); + } + else { + return interp->emptyObj; + } +} + +Jim_Obj *Jim_NamespaceTail(Jim_Interp *interp, Jim_Obj *ns) +{ + const char *name = Jim_String(ns); + const char *pt = strrchr(name, ':'); + if (pt && pt != name && pt[-1] == ':') { + return Jim_NewStringObj(interp, pt + 1, -1); + } + else { + return ns; + } +} + +static Jim_Obj *JimNamespaceCurrent(Jim_Interp *interp) +{ + Jim_Obj *objPtr = Jim_NewStringObj(interp, "::", 2); + Jim_AppendObj(interp, objPtr, interp->framePtr->nsObj); + return objPtr; +} + +static int JimVariableCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + int retcode = JIM_OK; + + if (argc > 3) { + Jim_WrongNumArgs(interp, 1, argv, "name ?value?"); + return JIM_ERR; + } + if (argc > 1) { + Jim_Obj *targetNameObj; + Jim_Obj *localNameObj; + +#if 0 + /* XXX should we give an error on dict sugar syntax? */ + if (JimValidName(interp, "variable", argv[1]) != JIM_OK) { + return JIM_ERR; + } +#endif + + targetNameObj = JimCanonicalNamespace(interp, interp->framePtr->nsObj, argv[1]); + + localNameObj = Jim_NamespaceTail(interp, argv[1]); + Jim_IncrRefCount(localNameObj); + if (interp->framePtr->level != 0 || Jim_Length(interp->framePtr->nsObj) != 0) { + Jim_CreateNamespaceVariable(interp, localNameObj, targetNameObj); + } + + /* Set the variable via the local name */ + if (argc > 2) { + retcode = Jim_SetVariable(interp, localNameObj, argv[2]); + } + Jim_DecrRefCount(interp, localNameObj); + } + return retcode; +} + +/* XXX: Temporary */ +static int Jim_EvalEnsemble(Jim_Interp *interp, const char *basecmd, const char *subcmd, int argc, Jim_Obj *const *argv) +{ + Jim_Obj *prefixObj = Jim_NewStringObj(interp, basecmd, -1); + + Jim_AppendString(interp, prefixObj, " ", 1); + Jim_AppendString(interp, prefixObj, subcmd, -1); + + return Jim_EvalObjPrefix(interp, prefixObj, argc, argv); +} + +static int JimNamespaceCmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv) +{ + Jim_Obj *nsObj; + Jim_Obj *objPtr; + int option; + static const char * const options[] = { + "eval", "current", "canonical", "qualifiers", "parent", "tail", "delete", + "origin", "code", "inscope", "import", "export", + "which", "upvar", NULL + }; + enum + { + OPT_EVAL, OPT_CURRENT, OPT_CANONICAL, OPT_QUALIFIERS, OPT_PARENT, OPT_TAIL, OPT_DELETE, + OPT_ORIGIN, OPT_CODE, OPT_INSCOPE, OPT_IMPORT, OPT_EXPORT, + OPT_WHICH, OPT_UPVAR, + }; + + if (argc < 2) { + Jim_WrongNumArgs(interp, 1, argv, "subcommand ?arg ...?"); + return JIM_ERR; + } + + if (Jim_GetEnum(interp, argv[1], options, &option, "subcommand", JIM_ERRMSG | JIM_ENUM_ABBREV) != JIM_OK) { + return JIM_ERR; + } + + switch (option) { + case OPT_EVAL: + if (argc < 4) { + Jim_WrongNumArgs(interp, 2, argv, "name arg ?arg...?"); + return JIM_ERR; + } + if (argc == 4) { + objPtr = argv[3]; + } + else { + objPtr = Jim_ConcatObj(interp, argc - 3, argv + 3); + } + + nsObj = JimCanonicalNamespace(interp, interp->framePtr->nsObj, argv[2]); + return Jim_EvalNamespace(interp, objPtr, nsObj); + + case OPT_CURRENT: + if (argc != 2) { + Jim_WrongNumArgs(interp, 2, argv, ""); + return JIM_ERR; + } + Jim_SetResult(interp, JimNamespaceCurrent(interp)); + return JIM_OK; + + case OPT_CANONICAL: + if (argc > 4) { + Jim_WrongNumArgs(interp, 2, argv, "?current? ?name?"); + return JIM_ERR; + } + if (argc == 2) { + Jim_SetResult(interp, interp->framePtr->nsObj); + } + else if (argc == 3) { + Jim_SetResult(interp, JimCanonicalNamespace(interp, interp->framePtr->nsObj, argv[2])); + } + else { + Jim_SetResult(interp, JimCanonicalNamespace(interp, argv[2], argv[3])); + } + return JIM_OK; + + case OPT_QUALIFIERS: + if (argc != 3) { + Jim_WrongNumArgs(interp, 2, argv, "string"); + return JIM_ERR; + } + Jim_SetResult(interp, Jim_NamespaceQualifiers(interp, argv[2])); + return JIM_OK; + + case OPT_EXPORT: + return JIM_OK; + + case OPT_TAIL: + if (argc != 3) { + Jim_WrongNumArgs(interp, 2, argv, "string"); + return JIM_ERR; + } + Jim_SetResult(interp, Jim_NamespaceTail(interp, argv[2])); + return JIM_OK; + + case OPT_PARENT: + if (argc != 2 && argc != 3) { + Jim_WrongNumArgs(interp, 2, argv, "?name?"); + return JIM_ERR; + } + else { + const char *name; + + if (argc == 3) { + objPtr = argv[2]; + } + else { + objPtr = interp->framePtr->nsObj; + } + if (Jim_Length(objPtr) == 0 || Jim_CompareStringImmediate(interp, objPtr, "::")) { + return JIM_OK; + } + objPtr = Jim_NamespaceQualifiers(interp, objPtr); + + name = Jim_String(objPtr); + + if (name[0] != ':' || name[1] != ':') { + /* Make it fully scoped */ + Jim_SetResultString(interp, "::", 2); + Jim_AppendObj(interp, Jim_GetResult(interp), objPtr); + Jim_IncrRefCount(objPtr); + Jim_DecrRefCount(interp, objPtr); + } + else { + Jim_SetResult(interp, objPtr); + } + } + return JIM_OK; + } + + /* Implemented as a Tcl helper proc. + * Note that calling a proc will change the current namespace, + * so helper procs must call [uplevel namespace canon] to get the callers + * namespace. + */ + return Jim_EvalEnsemble(interp, "namespace", options[option], argc - 2, argv + 2); +} + +int Jim_namespaceInit(Jim_Interp *interp) +{ + if (Jim_PackageProvide(interp, "namespace", "1.0", JIM_ERRMSG)) + return JIM_ERR; + + Jim_CreateCommand(interp, "namespace", JimNamespaceCmd, NULL, NULL); + Jim_CreateCommand(interp, "variable", JimVariableCmd, NULL, NULL); + return JIM_OK; +} + @@ -235,7 +235,6 @@ first: /* Glob-style pattern matching. */ /* Note: string *must* be valid UTF-8 sequences - * slen is a char length, not byte counts. */ static int JimGlobMatch(const char *pattern, const char *string, int nocase) { @@ -1476,8 +1475,10 @@ static int JimParseVar(struct JimParserCtx *pc) while (1) { /* Skip double colon, but not single colon! */ if (pc->p[0] == ':' && pc->p[1] == ':') { - pc->p += 2; - pc->len -= 2; + while (*pc->p == ':') { + pc->p++; + pc->len--; + } continue; } /* Note that any char >= 0x80 must be part of a utf-8 char. @@ -3523,6 +3524,7 @@ static void JimDecrCmdRefCount(Jim_Interp *interp, Jim_Cmd *cmdPtr) if (cmdPtr->isproc) { Jim_DecrRefCount(interp, cmdPtr->u.proc.argListObjPtr); Jim_DecrRefCount(interp, cmdPtr->u.proc.bodyObjPtr); + Jim_DecrRefCount(interp, cmdPtr->u.proc.nsObj); if (cmdPtr->u.proc.staticVars) { Jim_FreeHashTable(cmdPtr->u.proc.staticVars); Jim_Free(cmdPtr->u.proc.staticVars); @@ -3584,6 +3586,38 @@ static const Jim_HashTableType JimCommandsHashTableType = { /* ------------------------- Commands related functions --------------------- */ +#ifdef jim_ext_namespace +/** + * Qualifies 'name' with the current namespace if necessary and + * returns the "unscoped" name (that is, without the leading ::). + * The object stored in *objPtrPtr should be decremented after use. + */ +static const char *JimQualifyName(Jim_Interp *interp, const char *name, Jim_Obj **objPtrPtr) +{ + Jim_Obj *objPtr = interp->emptyObj; + + if (name[0] == ':' && name[1] == ':') { + /* This command is being defined in the global namespace */ + while (*++name == ':') { + } + } + else if (Jim_Length(interp->framePtr->nsObj)) { + /* This command is being defined in a non-global namespace */ + objPtr = Jim_DuplicateObj(interp, interp->framePtr->nsObj); + Jim_AppendStrings(interp, objPtr, "::", name, NULL); + name = Jim_String(objPtr); + } + Jim_IncrRefCount(objPtr); + *objPtrPtr = objPtr; + return name; +} + #define JimFreeQualifiedName(INTERP, OBJ) Jim_DecrRefCount((INTERP), (OBJ)) +#else + /* We can be more efficient in the no-namespace case */ + #define JimQualifyName(INTERP, NAME, DUMMY) (((NAME)[0] == ':' && (NAME)[1] == ':') ? (NAME) + 2 : (NAME)) + #define JimFreeQualifiedName(INTERP, DUMMY) (void)(DUMMY) +#endif + static int JimCreateCommand(Jim_Interp *interp, const char *name, Jim_Cmd *cmd) { /* It may already exist, so we try to delete the old one. @@ -3700,14 +3734,36 @@ static int JimCreateProcedureStatics(Jim_Interp *interp, Jim_Cmd *cmdPtr, Jim_Ob return JIM_OK; } -static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdName, +static void JimUpdateProcNamespace(Jim_Interp *interp, Jim_Cmd *cmdPtr, const char *cmdname) +{ +#ifdef jim_ext_namespace + if (cmdPtr->isproc) { + /* XXX: Really need JimNamespaceSplit() */ + const char *pt = strrchr(cmdname, ':'); + if (pt && pt != cmdname && pt[-1] == ':') { + Jim_DecrRefCount(interp, cmdPtr->u.proc.nsObj); + cmdPtr->u.proc.nsObj = Jim_NewStringObj(interp, cmdname, pt - cmdname - 1); + Jim_IncrRefCount(cmdPtr->u.proc.nsObj); + + if (Jim_FindHashEntry(&interp->commands, pt + 1)) { + /* This commands shadows a global command, so a proc epoch update is required */ + Jim_InterpIncrProcEpoch(interp); + } + } + } +#endif +} + +static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdNameObj, Jim_Obj *argListObjPtr, Jim_Obj *staticsListObjPtr, Jim_Obj *bodyObjPtr) { Jim_Cmd *cmdPtr; int argListLen; int i; + Jim_Obj *qualifiedCmdNameObj; + const char *cmdname; - if (JimValidName(interp, "procedure", cmdName) != JIM_OK) { + if (JimValidName(interp, "procedure", cmdNameObj) != JIM_OK) { return JIM_ERR; } @@ -3723,8 +3779,10 @@ static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdName, cmdPtr->u.proc.bodyObjPtr = bodyObjPtr; cmdPtr->u.proc.argsPos = -1; cmdPtr->u.proc.arglist = (struct Jim_ProcArg *)(cmdPtr + 1); + cmdPtr->u.proc.nsObj = interp->emptyObj; Jim_IncrRefCount(argListObjPtr); Jim_IncrRefCount(bodyObjPtr); + Jim_IncrRefCount(cmdPtr->u.proc.nsObj); /* Create the statics hash table. */ if (staticsListObjPtr && JimCreateProcedureStatics(interp, cmdPtr, staticsListObjPtr) != JIM_OK) { @@ -3745,7 +3803,9 @@ static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdName, len = Jim_ListLength(interp, argPtr); if (len == 0) { Jim_SetResultString(interp, "procedure has argument with no name", -1); - goto err; +err: + JimDecrCmdRefCount(interp, cmdPtr); + return JIM_ERR; } if (len > 2) { Jim_SetResultString(interp, "procedure has argument with too many fields", -1); @@ -3785,72 +3845,106 @@ static int JimCreateProcedure(Jim_Interp *interp, Jim_Obj *cmdName, } /* Add the new command */ - JimCreateCommand(interp, Jim_String(cmdName), cmdPtr); + cmdname = JimQualifyName(interp, Jim_String(cmdNameObj), &qualifiedCmdNameObj); + + JimCreateCommand(interp, cmdname, cmdPtr); + + /* Calculate and set the namespace for this proc */ + JimUpdateProcNamespace(interp, cmdPtr, cmdname); + + JimFreeQualifiedName(interp, qualifiedCmdNameObj); /* Unlike Tcl, set the name of the proc as the result */ - Jim_SetResult(interp, cmdName); + Jim_SetResult(interp, cmdNameObj); return JIM_OK; - - err: - if (cmdPtr->u.proc.staticVars) { - Jim_FreeHashTable(cmdPtr->u.proc.staticVars); - } - Jim_Free(cmdPtr->u.proc.staticVars); - Jim_DecrRefCount(interp, argListObjPtr); - Jim_DecrRefCount(interp, bodyObjPtr); - Jim_Free(cmdPtr); - return JIM_ERR; } -int Jim_DeleteCommand(Jim_Interp *interp, const char *cmdName) +int Jim_DeleteCommand(Jim_Interp *interp, const char *name) { - if (Jim_DeleteHashEntry(&interp->commands, cmdName) == JIM_ERR) - return JIM_ERR; - Jim_InterpIncrProcEpoch(interp); - return JIM_OK; + int ret = JIM_OK; + Jim_Obj *qualifiedNameObj; + const char *qualname = JimQualifyName(interp, name, &qualifiedNameObj); + + if (Jim_DeleteHashEntry(&interp->commands, qualname) == JIM_ERR) { + Jim_SetResultFormatted(interp, "can't delete \"%s\": command doesn't exist", name); + ret = JIM_ERR; + } + else { + Jim_InterpIncrProcEpoch(interp); + } + + JimFreeQualifiedName(interp, qualifiedNameObj); + + return ret; } int Jim_RenameCommand(Jim_Interp *interp, const char *oldName, const char *newName) { + int ret = JIM_ERR; Jim_HashEntry *he; + Jim_Cmd *cmdPtr; + Jim_Obj *qualifiedOldNameObj; + Jim_Obj *qualifiedNewNameObj; + const char *fqold; + const char *fqnew; - /* Does it exist? */ - he = Jim_FindHashEntry(&interp->commands, oldName); - if (he == NULL) { - Jim_SetResultFormatted(interp, "can't %s \"%s\": command doesn't exist", - newName[0] ? "rename" : "delete", oldName); - return JIM_ERR; + if (newName[0] == 0) { + return Jim_DeleteCommand(interp, oldName); } - if (newName[0] == '\0') /* Delete! */ - return Jim_DeleteCommand(interp, oldName); + fqold = JimQualifyName(interp, oldName, &qualifiedOldNameObj); + fqnew = JimQualifyName(interp, newName, &qualifiedNewNameObj); - /* rename */ - if (Jim_FindHashEntry(&interp->commands, newName)) { + /* Does it exist? */ + he = Jim_FindHashEntry(&interp->commands, fqold); + if (he == NULL) { + Jim_SetResultFormatted(interp, "can't rename \"%s\": command doesn't exist", oldName); + } + else if (Jim_FindHashEntry(&interp->commands, fqnew)) { Jim_SetResultFormatted(interp, "can't rename to \"%s\": command already exists", newName); - return JIM_ERR; } + else { + /* Add the new name first */ + cmdPtr = he->u.val; + JimIncrCmdRefCount(cmdPtr); + JimUpdateProcNamespace(interp, cmdPtr, fqnew); + Jim_AddHashEntry(&interp->commands, fqnew, cmdPtr); - /* Add the new name first */ - JimIncrCmdRefCount(he->u.val); - Jim_AddHashEntry(&interp->commands, newName, he->u.val); + /* Now remove the old name */ + Jim_DeleteHashEntry(&interp->commands, fqold); - /* Now remove the old name */ - Jim_DeleteHashEntry(&interp->commands, oldName); + /* Increment the epoch */ + Jim_InterpIncrProcEpoch(interp); - /* Increment the epoch */ - Jim_InterpIncrProcEpoch(interp); - return JIM_OK; + ret = JIM_OK; + } + + JimFreeQualifiedName(interp, qualifiedOldNameObj); + JimFreeQualifiedName(interp, qualifiedNewNameObj); + + return ret; } /* ----------------------------------------------------------------------------- * Command object * ---------------------------------------------------------------------------*/ +static void FreeCommandInternalRep(Jim_Interp *interp, Jim_Obj *objPtr) +{ + Jim_DecrRefCount(interp, objPtr->internalRep.cmdValue.nsObj); +} + +static void DupCommandInternalRep(Jim_Interp *interp, Jim_Obj *srcPtr, Jim_Obj *dupPtr) +{ + dupPtr->internalRep.cmdValue = srcPtr->internalRep.cmdValue; + dupPtr->typePtr = srcPtr->typePtr; + Jim_IncrRefCount(dupPtr->internalRep.cmdValue.nsObj); +} + static const Jim_ObjType commandObjType = { "command", - NULL, - NULL, + FreeCommandInternalRep, + DupCommandInternalRep, NULL, JIM_TYPE_REFERENCES, }; @@ -3867,26 +3961,62 @@ Jim_Cmd *Jim_GetCommand(Jim_Interp *interp, Jim_Obj *objPtr, int flags) { Jim_Cmd *cmd; + /* In order to be valid, the proc epoch must match and + * the lookup must have occurred in the same namespace + */ if (objPtr->typePtr != &commandObjType || - objPtr->internalRep.cmdValue.procEpoch != interp->procEpoch) { - + objPtr->internalRep.cmdValue.procEpoch != interp->procEpoch +#ifdef jim_ext_namespace + || !Jim_StringEqObj(objPtr->internalRep.cmdValue.nsObj, interp->framePtr->nsObj) +#endif + ) { /* Not cached or out of date, so lookup */ - Jim_HashEntry *he = Jim_FindHashEntry(&interp->commands, Jim_String(objPtr)); + + /* Do we need to try the local namespace? */ + const char *name = Jim_String(objPtr); + Jim_HashEntry *he; + + if (name[0] == ':' && name[1] == ':') { + while (*++name == ':') { + } + } +#ifdef jim_ext_namespace + else if (Jim_Length(interp->framePtr->nsObj)) { + /* This command is being defined in a non-global namespace */ + Jim_Obj *nameObj = Jim_DuplicateObj(interp, interp->framePtr->nsObj); + Jim_AppendStrings(interp, nameObj, "::", name, NULL); + he = Jim_FindHashEntry(&interp->commands, Jim_String(nameObj)); + Jim_FreeNewObj(interp, nameObj); + if (he) { + goto found; + } + } +#endif + + /* Lookup in the global namespace */ + he = Jim_FindHashEntry(&interp->commands, name); if (he == NULL) { if (flags & JIM_ERRMSG) { Jim_SetResultFormatted(interp, "invalid command name \"%#s\"", objPtr); } return NULL; } +#ifdef jim_ext_namespace +found: +#endif + cmd = (Jim_Cmd *)he->u.val; /* Free the old internal repr and set the new one. */ Jim_FreeIntRep(interp, objPtr); objPtr->typePtr = &commandObjType; objPtr->internalRep.cmdValue.procEpoch = interp->procEpoch; - objPtr->internalRep.cmdValue.cmdPtr = (void *)he->u.val; + objPtr->internalRep.cmdValue.cmdPtr = cmd; + objPtr->internalRep.cmdValue.nsObj = interp->framePtr->nsObj; + Jim_IncrRefCount(interp->framePtr->nsObj); + } + else { + cmd = objPtr->internalRep.cmdValue.cmdPtr; } - - cmd = objPtr->internalRep.cmdValue.cmdPtr; while (cmd->u.proc.upcall) { cmd = cmd->prevCmd; } @@ -3971,8 +4101,9 @@ static int SetVariableFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) } if (varName[0] == ':' && varName[1] == ':') { + while (*++varName == ':') { + } global = 1; - varName += 2; framePtr = interp->topFramePtr; } else { @@ -3982,12 +4113,14 @@ static int SetVariableFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) /* Resolve this name in the variables hash table */ he = Jim_FindHashEntry(&framePtr->vars, varName); - if (he == NULL && !global && framePtr->staticVars) { - /* Try with static vars. */ - he = Jim_FindHashEntry(framePtr->staticVars, varName); - } if (he == NULL) { - return JIM_ERR; + if (!global && framePtr->staticVars) { + /* Try with static vars. */ + he = Jim_FindHashEntry(framePtr->staticVars, varName); + } + if (he == NULL) { + return JIM_ERR; + } } /* Free the old internal repr and set the new one. */ @@ -4018,8 +4151,9 @@ static Jim_Var *JimCreateVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, Jim_O name = Jim_String(nameObjPtr); if (name[0] == ':' && name[1] == ':') { + while (*++name == ':') { + } framePtr = interp->topFramePtr; - name += 2; global = 1; } else { @@ -4155,8 +4289,9 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, varName = Jim_String(nameObjPtr); if (varName[0] == ':' && varName[1] == ':') { + while (*++varName == ':') { + } /* Linking a global var does nothing */ - varName += 2; framePtr = interp->topFramePtr; } else { @@ -4165,7 +4300,9 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, targetName = Jim_String(targetNameObjPtr); if (targetName[0] == ':' && targetName[1] == ':') { - targetNameObjPtr = Jim_NewStringObj(interp, targetName + 2, -1); + while (*++targetName == ':') { + } + targetNameObjPtr = Jim_NewStringObj(interp, targetName, -1); targetCallFrame = interp->topFramePtr; } Jim_IncrRefCount(targetNameObjPtr); @@ -4383,7 +4520,7 @@ static int JimDictSugarSet(Jim_Interp *interp, Jim_Obj *objPtr, Jim_Obj *valObjP SetDictSubstFromAny(interp, objPtr); err = Jim_SetDictKeysVector(interp, objPtr->internalRep.dictSubstValue.varNameObjPtr, - &objPtr->internalRep.dictSubstValue.indexObjPtr, 1, valObjPtr, JIM_ERRMSG); + &objPtr->internalRep.dictSubstValue.indexObjPtr, 1, valObjPtr, JIM_MUSTEXIST); if (err == JIM_OK) { /* Don't keep an extra ref to the result */ @@ -4545,7 +4682,7 @@ static Jim_Obj *JimExpandExprSugar(Jim_Interp *interp, Jim_Obj *objPtr) * CallFrame * ---------------------------------------------------------------------------*/ -static Jim_CallFrame *JimCreateCallFrame(Jim_Interp *interp, Jim_CallFrame *parent) +static Jim_CallFrame *JimCreateCallFrame(Jim_Interp *interp, Jim_CallFrame *parent, Jim_Obj *nsObj) { Jim_CallFrame *cf; @@ -4569,6 +4706,8 @@ static Jim_CallFrame *JimCreateCallFrame(Jim_Interp *interp, Jim_CallFrame *pare cf->staticVars = NULL; cf->localCommands = NULL; + cf->nsObj = nsObj; + Jim_IncrRefCount(nsObj); if (cf->vars.table == NULL) Jim_InitHashTable(&cf->vars, &JimVariablesHashTableType, interp); return cf; @@ -4588,8 +4727,11 @@ static int JimDeleteLocalProcs(Jim_Interp *interp, Jim_Stack *localCommands) while ((cmdNameObj = Jim_StackPop(localCommands)) != NULL) { Jim_HashEntry *he; + Jim_Obj *fqObjName; + + const char *fqname = JimQualifyName(interp, Jim_String(cmdNameObj), &fqObjName); - he = Jim_FindHashEntry(&interp->commands, Jim_String(cmdNameObj)); + he = Jim_FindHashEntry(&interp->commands, fqname); if (he) { Jim_Cmd *cmd = he->u.val; @@ -4604,11 +4746,12 @@ static int JimDeleteLocalProcs(Jim_Interp *interp, Jim_Stack *localCommands) he->u.val = prevCmd; } else { - Jim_DeleteHashEntry(&interp->commands, Jim_String(cmdNameObj)); + Jim_DeleteHashEntry(&interp->commands, fqname); Jim_InterpIncrProcEpoch(interp); } } Jim_DecrRefCount(interp, cmdNameObj); + JimFreeQualifiedName(interp, fqObjName); } Jim_FreeStack(localCommands); Jim_Free(localCommands); @@ -4625,6 +4768,7 @@ static void JimFreeCallFrame(Jim_Interp *interp, Jim_CallFrame *cf, int flags) Jim_DecrRefCount(interp, cf->procArgsObjPtr); if (cf->procBodyObjPtr) Jim_DecrRefCount(interp, cf->procBodyObjPtr); + Jim_DecrRefCount(interp, cf->nsObj); if (!(flags & JIM_FCF_NOHT)) Jim_FreeHashTable(&cf->vars); else { @@ -5095,10 +5239,10 @@ Jim_Interp *Jim_CreateInterp(void) #endif Jim_InitHashTable(&i->assocData, &JimAssocDataHashTableType, i); Jim_InitHashTable(&i->packages, &JimPackageHashTableType, NULL); - i->framePtr = i->topFramePtr = JimCreateCallFrame(i, NULL); i->emptyObj = Jim_NewEmptyStringObj(i); i->trueObj = Jim_NewIntObj(i, 1); i->falseObj = Jim_NewIntObj(i, 0); + i->framePtr = i->topFramePtr = JimCreateCallFrame(i, NULL, i->emptyObj); i->errorFileNameObj = i->emptyObj; i->result = i->emptyObj; i->stackTrace = Jim_NewListObj(i, NULL, 0); @@ -5168,8 +5312,14 @@ void Jim_FreeInterp(Jim_Interp *i) while (objPtr) { const char *type = objPtr->typePtr ? objPtr->typePtr->name : "string"; - printf("%p (%d) %-10s: '%.20s'" JIM_NL, - (void *)objPtr, objPtr->refCount, type, objPtr->bytes ? objPtr->bytes : "(null)"); + if (objPtr->bytes && strlen(objPtr->bytes) > 20) { + printf("%p (%d) %-10s: '%.20s...'" JIM_NL, + (void *)objPtr, objPtr->refCount, type, objPtr->bytes); + } + else { + printf("%p (%d) %-10s: '%s'" JIM_NL, + (void *)objPtr, objPtr->refCount, type, objPtr->bytes ? objPtr->bytes : "(null)"); + } if (objPtr->typePtr == &sourceObjType) { printf("FILE %s LINE %d" JIM_NL, Jim_String(objPtr->internalRep.sourceValue.fileNameObj), @@ -6751,7 +6901,7 @@ int Jim_SetDictKeysVector(Jim_Interp *interp, Jim_Obj *varNamePtr, varObjPtr = objPtr = Jim_GetVariable(interp, varNamePtr, flags); if (objPtr == NULL) { - if (newObjPtr == NULL && (flags & JIM_ERRMSG)) { + if (newObjPtr == NULL && (flags & JIM_MUSTEXIST)) { /* Cannot remove a key from non existing var */ return JIM_ERR; } @@ -6774,7 +6924,7 @@ int Jim_SetDictKeysVector(Jim_Interp *interp, Jim_Obj *varNamePtr, if (i == keyc - 1) { /* Last key: Note that error on unset with missing last key is OK */ if (Jim_DictAddElement(interp, objPtr, keyv[keyc - 1], newObjPtr) != JIM_OK) { - if (newObjPtr || (flags & JIM_ERRMSG)) { + if (newObjPtr || (flags & JIM_MUSTEXIST)) { goto err; } } @@ -10271,6 +10421,50 @@ static void JimSetProcWrongArgs(Jim_Interp *interp, Jim_Obj *procNameObj, Jim_Cm Jim_FreeNewObj(interp, argmsg); } +#ifdef jim_ext_namespace +/* + * [namespace eval] + */ +int Jim_EvalNamespace(Jim_Interp *interp, Jim_Obj *scriptObj, Jim_Obj *nsObj) +{ + Jim_CallFrame *callFramePtr; + int retcode; + + /* Create a new callframe */ + callFramePtr = JimCreateCallFrame(interp, interp->framePtr, nsObj); + callFramePtr->argv = &interp->emptyObj; + callFramePtr->argc = 0; + callFramePtr->procArgsObjPtr = NULL; + callFramePtr->procBodyObjPtr = scriptObj; + callFramePtr->staticVars = NULL; + callFramePtr->fileNameObj = interp->emptyObj; + callFramePtr->line = 0; + Jim_IncrRefCount(scriptObj); + interp->framePtr = callFramePtr; + + /* Check if there are too nested calls */ + if (interp->framePtr->level == interp->maxCallFrameDepth) { + Jim_SetResultString(interp, "Too many nested calls. Infinite recursion?", -1); + retcode = JIM_ERR; + } + else { + /* Eval the body */ + retcode = Jim_EvalObj(interp, scriptObj); + } + + /* Destroy the callframe */ + interp->framePtr = interp->framePtr->parent; + if (callFramePtr->vars.size != JIM_HT_INITIAL_SIZE) { + JimFreeCallFrame(interp, callFramePtr, JIM_FCF_NONE); + } + else { + JimFreeCallFrame(interp, callFramePtr, JIM_FCF_NOHT); + } + + return retcode; +} +#endif + /* Call a procedure implemented in Tcl. * It's possible to speed-up a lot this function, currently * the callframes are not cached, but allocated and @@ -10300,7 +10494,7 @@ static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj } /* Create a new callframe */ - callFramePtr = JimCreateCallFrame(interp, interp->framePtr); + callFramePtr = JimCreateCallFrame(interp, interp->framePtr, cmd->u.proc.nsObj); callFramePtr->argv = argv; callFramePtr->argc = argc; callFramePtr->procArgsObjPtr = cmd->u.proc.argListObjPtr; @@ -12640,7 +12834,8 @@ static int Jim_AliasCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *ar Jim_IncrRefCount(prefixListObj); newname = Jim_String(argv[1]); if (newname[0] == ':' && newname[1] == ':') { - newname += 2; + while (*++newname == ':') { + } } Jim_SetResult(interp, argv[1]); @@ -12679,8 +12874,7 @@ static int Jim_LocalCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *ar if (retcode == 0) { Jim_Obj *cmdNameObj = Jim_GetResult(interp); - if (Jim_FindHashEntry(&interp->commands, Jim_String(cmdNameObj)) == NULL) { - Jim_SetResultFormatted(interp, "not a command: \"%#s\"", cmdNameObj); + if (Jim_GetCommand(interp, cmdNameObj, JIM_ERRMSG) == NULL) { return JIM_ERR; } if (interp->framePtr->localCommands == NULL) { @@ -13454,8 +13648,6 @@ static int JimInfoReferences(Jim_Interp *interp, int argc, Jim_Obj *const *argv) /* [rename] */ static int Jim_RenameCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { - const char *oldName, *newName; - if (argc != 3) { Jim_WrongNumArgs(interp, 1, argv, "oldName newName"); return JIM_ERR; @@ -13465,9 +13657,7 @@ static int Jim_RenameCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *a return JIM_ERR; } - oldName = Jim_String(argv[1]); - newName = Jim_String(argv[2]); - return Jim_RenameCommand(interp, oldName, newName); + return Jim_RenameCommand(interp, Jim_String(argv[1]), Jim_String(argv[2])); } #define JIM_DICTMATCH_VALUES 0x0001 @@ -13694,6 +13884,7 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg int cmd; Jim_Obj *objPtr; int mode = 0; + int nons = 0; static const char * const commands[] = { "body", "statics", "commands", "procs", "channels", "exists", "globals", "level", "frame", "locals", @@ -13712,6 +13903,12 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg Jim_WrongNumArgs(interp, 1, argv, "subcommand ?args ...?"); return JIM_ERR; } + if (argc > 2 && Jim_CompareStringImmediate(interp, argv[1], "-nons")) { + /* This is for internal use only */ + argc--; + argv++; + nons = 1; + } if (Jim_GetEnum(interp, argv[1], commands, &cmd, "subcommand", JIM_ERRMSG | JIM_ENUM_ABBREV) != JIM_OK) { return JIM_ERR; @@ -13759,6 +13956,13 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg Jim_WrongNumArgs(interp, 2, argv, "?pattern?"); return JIM_ERR; } +#ifdef jim_ext_namespace + if (!nons) { + if (Jim_Length(interp->framePtr->nsObj) || (argc == 3 && JimGlobMatch("::*", Jim_String(argv[2]), 0))) { + return Jim_EvalPrefix(interp, "namespace info", argc - 1, argv + 1); + } + } +#endif Jim_SetResult(interp, JimCommandsList(interp, (argc == 3) ? argv[2] : NULL, mode)); break; @@ -13772,6 +13976,13 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg Jim_WrongNumArgs(interp, 2, argv, "?pattern?"); return JIM_ERR; } +#ifdef jim_ext_namespace + if (!nons) { + if (Jim_Length(interp->framePtr->nsObj) || (argc == 3 && JimGlobMatch("::*", Jim_String(argv[2]), 0))) { + return Jim_EvalPrefix(interp, "namespace info", argc - 1, argv + 1); + } + } +#endif Jim_SetResult(interp, JimVariablesList(interp, argc == 3 ? argv[2] : NULL, mode)); break; @@ -149,6 +149,10 @@ extern "C" { #define JIM_ERRMSG 1 /* set an error message in the interpreter. */ #define JIM_UNSHARED 4 /* Flag to Jim_GetVariable() */ +#define JIM_MUSTEXIST 8 /* Flag to Jim_SetDictKeysVector() - fail if non-existent */ + +/* Internal flags */ +#define JIM_GLOBAL_ONLY 0x100 /* Flags for Jim_SubstObj() */ #define JIM_SUBST_NOVAR 1 /* don't perform variables substitutions */ @@ -309,6 +313,7 @@ typedef struct Jim_Obj { /* Command object */ struct { unsigned long procEpoch; /* for caching */ + struct Jim_Obj *nsObj; struct Jim_Cmd *cmdPtr; } cmdValue; /* List object */ @@ -438,6 +443,7 @@ typedef struct Jim_CallFrame { Jim_Obj *procArgsObjPtr; /* arglist object of the running procedure */ Jim_Obj *procBodyObjPtr; /* body object of the running procedure */ struct Jim_CallFrame *next; /* Callframes are in a linked list */ + Jim_Obj *nsObj; /* Namespace for this proc call frame */ Jim_Obj *fileNameObj; /* file and line of caller of this proc (if available) */ int line; Jim_Stack *localCommands; /* commands to be destroyed when the call frame is destroyed */ @@ -490,6 +496,7 @@ typedef struct Jim_Cmd { Jim_Obj *nameObjPtr; /* Name of this arg */ Jim_Obj *defaultObjPtr; /* Default value, (or rename for $args) */ } *arglist; + Jim_Obj *nsObj; /* Namespace for this proc */ } proc; } u; } Jim_Cmd; @@ -645,6 +652,7 @@ JIM_EXPORT int Jim_EvalObjList(Jim_Interp *interp, Jim_Obj *listObj); JIM_EXPORT int Jim_EvalObjPrefix(Jim_Interp *interp, Jim_Obj *prefix, int objc, Jim_Obj *const *objv); #define Jim_EvalPrefix(i, p, oc, ov) Jim_EvalObjPrefix((i), Jim_NewStringObj((i), (p), -1), (oc), (ov)) +JIM_EXPORT int Jim_EvalNamespace(Jim_Interp *interp, Jim_Obj *scriptObj, Jim_Obj *nsObj); JIM_EXPORT int Jim_SubstObj (Jim_Interp *interp, Jim_Obj *substObjPtr, Jim_Obj **resObjPtrPtr, int flags); @@ -758,6 +766,9 @@ JIM_EXPORT int Jim_SetVariableStrWithStr (Jim_Interp *interp, JIM_EXPORT int Jim_SetVariableLink (Jim_Interp *interp, Jim_Obj *nameObjPtr, Jim_Obj *targetNameObjPtr, Jim_CallFrame *targetCallFrame); +JIM_EXPORT int Jim_CreateNamespaceVariable(Jim_Interp *interp, + Jim_Obj *varNameObj, Jim_Obj *targetNameObj); +JIM_EXPORT int Jim_DiscardNamespaceVars(Jim_Interp *interp); JIM_EXPORT Jim_Obj * Jim_GetVariable (Jim_Interp *interp, Jim_Obj *nameObjPtr, int flags); JIM_EXPORT Jim_Obj * Jim_GetGlobalVariable (Jim_Interp *interp, diff --git a/nshelper.tcl b/nshelper.tcl new file mode 100644 index 0000000..c91973f --- /dev/null +++ b/nshelper.tcl @@ -0,0 +1,124 @@ +proc {namespace delete} {args} { + foreach name $args { + if {$name ni {:: ""}} { + set name [uplevel 1 [list ::namespace canon $name]] + foreach i [info commands ${name}::*] { rename $i "" } + uplevel #0 [list unset {*}[info globals ${name}::*]] + } + } +} + +proc {namespace origin} {name} { + set nscanon [uplevel 1 [list ::namespace canon $name]] + if {[exists -alias $nscanon]} { + tailcall {namespace origin} [info alias $nscanon] + } + if {[exists -command $nscanon]} { + return ::$nscanon + } + if {[exists -command $name]} { + return ::$name + } + + return -code error "invalid command name \"$name\"" +} + +proc {namespace which} {{type -command} name} { + set nsname ::[uplevel 1 [list ::namespace canon $name]] + if {$type eq "-variable"} { + return $nsname + } + if {$type eq "-command"} { + if {[exists -command $nsname]} { + return $nsname + } elseif {[exists -command ::$name]} { + return ::$name + } + return "" + } + return -code error {wrong # args: should be "namespace which ?-command? ?-variable? name"} +} + + +proc {namespace code} {arg} { + if {[string first "::namespace inscope " $arg] == 0} { + # Already scoped + return $arg + } + list ::namespace inscope [uplevel 1 ::namespace current] $arg +} + +proc {namespace inscope} {name arg args} { + tailcall namespace eval $name $arg $args +} + +proc {namespace import} {args} { + set current [uplevel 1 ::namespace canon] + + foreach pattern $args { + foreach cmd [info commands [namespace canon $current $pattern]] { + alias ${current}::[namespace tail $cmd] $cmd + } + } +} + +# namespace-aware info commands: procs, channels, globals, locals, vars +proc {namespace info} {cmd {pattern *}} { + set current [uplevel 1 ::namespace canon] + # Now we may need to strip $pattern + if {[string first :: $pattern] == 0} { + set global 1 + set prefix :: + } else { + set global 0 + set clen [string length $current] + incr clen 2 + } + set fqp [namespace canon $current $pattern] + switch -glob -- $cmd { + co* - p* { + if {$global} { + set result [info $cmd $fqp] + } else { + # Add commands in the current namespace + set r {} + foreach c [info $cmd $fqp] { + dict set r [string range $c $clen end] 1 + } + if {[string match co* $cmd]} { + # Now in the global namespace + foreach c [info -nons commands $pattern] { + dict set r $c 1 + } + } + set result [dict keys $r] + } + } + ch* { + set result [info channels $pattern] + } + v* { + #puts "uplevel #0 info gvars $fqp" + set result [uplevel #0 info -nons vars $fqp] + } + g* { + set result [info globals $fqp] + } + l* { + set result [uplevel 1 info -nons locals $pattern] + } + } + if {$global} { + set result [lmap p $result { set p $prefix$p }] + } + return $result +} + +proc {namespace upvar} {ns args} { + set nscanon ::[uplevel 1 [list ::namespace canon $ns]] + set script [list upvar 0] + foreach {other local} $args { + lappend script ${nscanon}::$other $local + } + tailcall {*}$script +} diff --git a/tests/alias.test b/tests/alias.test index 9e866a2..b1774fd 100644 --- a/tests/alias.test +++ b/tests/alias.test @@ -121,7 +121,7 @@ test local-1.7 "check no reference procs" { test local-1.8 "local on non-existent command" { list [catch {local set x blah} msg] $msg -} {1 {not a command: "blah"}} +} {1 {invalid command name "blah"}} test local-1.9 "local on existing proc" { proc x {} { diff --git a/tests/namespace.test b/tests/namespace.test new file mode 100644 index 0000000..5707cf8 --- /dev/null +++ b/tests/namespace.test @@ -0,0 +1,493 @@ +source [file dirname [info script]]/testing.tcl +needs cmd namespace + +test namespace-1.1 {usage for "namespace" command} -body { + namespace +} -returnCodes error -match glob -result {wrong # args: should be *} + +test namespace-1.2 {global namespace's name is "::" or {}} { + list [namespace current] [namespace eval {} {namespace current}] [namespace eval :: {namespace current}] +} {:: :: ::} + +test namespace-1.3 {usage for "namespace eval"} -body { + namespace eval +} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"} + +test namespace-1.5 {access a new namespace} { + namespace eval ns1 { namespace current } +} {::ns1} + +test namespace-1.7 {usage for "namespace eval"} -body { + namespace eval ns1 +} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"} + +test namespace-1.8 {command "namespace eval" concatenates args} { + namespace eval ns1 namespace current +} {::ns1} + +test namespace-1.9 {simple namespace elements} { + namespace eval ns1 { + variable v1 1 + proc p1 {a} {variable v1; list $a $v1} + p1 3 + } +} {3 1} + +test namespace-1.10 {commands in a namespace} { + namespace eval ns1 { + info commands [namespace current]::* + } +} {::ns1::p1} + +test namespace-1.11 {variables in a namespace} { + namespace eval ns1 { + info vars [namespace current]::* + } +} {::ns1::v1} + +test namespace-1.12 {global vars are separate from locals vars} { + set v1 2 + list [ns1::p1 123] [set ns1::v1] [set ::v1] +} {{123 1} 1 2} + +test namespace-1.13 {add to an existing namespace} { + namespace eval ns1 { + variable v2 22 + proc p2 {script} {variable v2; eval $script} + p2 {return $v2} + } +} 22 + +test namespace-1.14 {commands in a namespace} { + lsort [namespace eval ns1 {info commands [namespace current]::*}] +} {::ns1::p1 ::ns1::p2} + +test namespace-1.15 {variables in a namespace} { + lsort [namespace eval ns1 {info vars [namespace current]::*}] +} {::ns1::v1 ::ns1::v2} + +# Tcl produces fully scoped names here +test namespace-1.16 {variables in a namespace} jim { + lsort [info vars ns1::*] +} {ns1::v1 ns1::v2} + +test namespace-1.17 {commands in a namespace are hidden} -body { + v2 {return 3} +} -returnCodes error -result {invalid command name "v2"} + +test namespace-1.18 {using namespace qualifiers} { + ns1::p2 {return 44} +} 44 + +test namespace-1.19 {using absolute namespace qualifiers} { + ::ns1::p2 {return 55} +} 55 + +test namespace-1.20 {variables in a namespace are hidden} -body { + set v2 +} -returnCodes error -result {can't read "v2": no such variable} + +test namespace-1.21 {using namespace qualifiers} { + list $ns1::v1 $ns1::v2 +} {1 22} + +test namespace-1.22 {using absolute namespace qualifiers} { + list $::ns1::v1 $::ns1::v2 +} {1 22} + +test namespace-1.23 {variables can be accessed within a namespace} { + ns1::p2 { + variable v1 + variable v2 + list $v1 $v2 + } +} {1 22} + +test namespace-1.24 {setting global variables} { + ns1::p2 { + variable v1 + set v1 new + } + namespace eval ns1 { + variable v1 + variable v2 + list $v1 $v2 + } +} {new 22} + +test namespace-1.25 {qualified variables don't need a global declaration} { + namespace eval ns2 { variable x 456 } + set cmd {set ::ns2::x} + ns1::p2 "$cmd some-value" + set ::ns2::x +} {some-value} + +test namespace-1.26 {namespace qualifiers are okay after $'s} { + namespace eval ns1 { variable x; variable y; set x 12; set y 34 } + set cmd {list $::ns1::x $::ns1::y} + list [ns1::p2 $cmd] [eval $cmd] +} {{12 34} {12 34}} + +test namespace-1.27 {can create commands with null names} { + proc ns1:: {args} {return $args} + ns1:: x +} {x} + +unset -nocomplain ns1::x ns1::y + +# ----------------------------------------------------------------------- +# TEST: using "info" in namespace contexts +# ----------------------------------------------------------------------- +test namespace-2.1 {querying: info commands} { + lsort [ns1::p2 {info commands [namespace current]::*}] +} {::ns1:: ::ns1::p1 ::ns1::p2} + +test namespace-2.2 {querying: info procs} { + lsort [ns1::p2 {info procs}] +} {{} p1 p2} + +# Tcl produces fully scoped names here +test namespace-2.3 {querying: info vars} jim { + lsort [info vars ns1::*] +} {ns1::v1 ns1::v2} + +test namespace-2.4 {querying: info vars} { + lsort [ns1::p2 {info vars [namespace current]::*}] +} {::ns1::v1 ::ns1::v2} + +test namespace-2.5 {querying: info locals} { + lsort [ns1::p2 {info locals}] +} {script} + +test namespace-2.6 {querying: info exists} { + ns1::p2 {info exists v1} +} {0} + +test namespace-2.7 {querying: info exists} { + ns1::p2 {info exists v2} +} {1} + +test namespace-2.8 {querying: info args} { + info args ns1::p2 +} {script} + +test namespace-2.9 {querying: info body} { + string trim [info body ns1::p1] +} {variable v1; list $a $v1} + +# ----------------------------------------------------------------------- +# TEST: namespace qualifiers, namespace tail +# ----------------------------------------------------------------------- +test namespace-3.1 {usage for "namespace qualifiers"} { + list [catch "namespace qualifiers" msg] $msg +} {1 {wrong # args: should be "namespace qualifiers string"}} + +test namespace-3.2 {querying: namespace qualifiers} { + list [namespace qualifiers ""] \ + [namespace qualifiers ::] \ + [namespace qualifiers x] \ + [namespace qualifiers ::x] \ + [namespace qualifiers foo::x] \ + [namespace qualifiers ::foo::bar::xyz] +} {{} {} {} {} foo ::foo::bar} + +test namespace-3.3 {usage for "namespace tail"} { + list [catch "namespace tail" msg] $msg +} {1 {wrong # args: should be "namespace tail string"}} + +test namespace-3.4 {querying: namespace tail} { + list [namespace tail ""] \ + [namespace tail ::] \ + [namespace tail x] \ + [namespace tail ::x] \ + [namespace tail foo::x] \ + [namespace tail ::foo::bar::xyz] +} {{} {} x x x xyz} + +# ----------------------------------------------------------------------- +# TEST: namespace hierarchy +# ----------------------------------------------------------------------- +test namespace-5.1 {define nested namespaces} { + set test_ns_var_global "var in ::" + proc test_ns_cmd_global {} {return "cmd in ::"} + namespace eval nsh1 { + set test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + proc test_ns_show {} {return "[namespace current]: 1"} + namespace eval nsh2 { + set test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + proc test_ns_show {} {return "[namespace current]: 2"} + namespace eval nsh3a {} + namespace eval nsh3b {} + } + namespace eval nsh2a {} + namespace eval nsh2b {} + } +} {} + +test namespace-5.2 {namespaces can be nested} { + list [namespace eval nsh1 {namespace current}] \ + [namespace eval nsh1 { + namespace eval nsh2 {namespace current} + }] +} {::nsh1 ::nsh1::nsh2} + +test namespace-5.3 {namespace qualifiers work in namespace command} { + list [namespace eval ::nsh1 {namespace current}] \ + [namespace eval nsh1::nsh2 {namespace current}] \ + [namespace eval ::nsh1::nsh2 {namespace current}] +} {::nsh1 ::nsh1::nsh2 ::nsh1::nsh2} + +test namespace-5.4 {nested namespaces can access global namespace} { + list [namespace eval nsh1 {set ::test_ns_var_global}] \ + [namespace eval nsh1 {test_ns_cmd_global}] \ + [namespace eval nsh1::nsh2 {set ::test_ns_var_global}] \ + [namespace eval nsh1::nsh2 {test_ns_cmd_global}] +} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} + +test namespace-5.6 {commands in different namespaces don't conflict} { + list [nsh1::test_ns_show] \ + [nsh1::nsh2::test_ns_show] +} {{::nsh1: 1} {::nsh1::nsh2: 2}} +test namespace-5.7 {nested namespaces don't see variables in parent} { + set cmd { + namespace eval nsh1::nsh2 {set test_ns_var_hier1} + } + list [catch $cmd msg] $msg +} {1 {can't read "test_ns_var_hier1": no such variable}} +test namespace-5.8 {nested namespaces don't see commands in parent} { + set cmd { + namespace eval nsh1::nsh2 {test_ns_cmd_hier1} + } + list [catch $cmd msg] $msg +} {1 {invalid command name "test_ns_cmd_hier1"}} + +test namespace-5.18 {usage for "namespace parent"} { + list [catch {namespace parent x y} msg] $msg +} {1 {wrong # args: should be "namespace parent ?name?"}} + +test namespace-5.20 {querying namespace parent} { + list [namespace eval :: {namespace parent}] \ + [namespace eval nsh1 {namespace parent}] \ + [namespace eval nsh1::nsh2 {namespace parent}] \ + [namespace eval nsh1::nsh2::nsh3a {namespace parent}] \ +} {{} :: ::nsh1 ::nsh1::nsh2} + +test namespace-5.21 {querying namespace parent for explicit namespace} { + list [namespace parent ::] \ + [namespace parent nsh1] \ + [namespace parent nsh1::nsh2] \ + [namespace parent nsh1::nsh2::nsh3a] +} {{} :: ::nsh1 ::nsh1::nsh2} + +# ----------------------------------------------------------------------- +# TEST: name resolution and caching +# ----------------------------------------------------------------------- +test namespace-6.1 {relative ns names only looked up in current ns} { + namespace eval tns1 {} + namespace eval tns2 {} + namespace eval tns2::test_ns_cache3 {} + set trigger { + namespace eval tns2 {namespace current} + } + set trigger2 { + namespace eval tns2::test_ns_cache3 {namespace current} + } + list [namespace eval tns1 $trigger] \ + [namespace eval tns1 $trigger2] +} {::tns1::tns2 ::tns1::tns2::test_ns_cache3} +test namespace-6.2 {relative ns names only looked up in current ns} { + namespace eval tns1::tns2 {} + list [namespace eval tns1 $trigger] \ + [namespace eval tns1 $trigger2] +} {::tns1::tns2 ::tns1::tns2::test_ns_cache3} +test namespace-6.3 {relative ns names only looked up in current ns} { + namespace eval tns1::tns2::test_ns_cache3 {} + list [namespace eval tns1 $trigger] \ + [namespace eval tns1 $trigger2] +} {::tns1::tns2 ::tns1::tns2::test_ns_cache3} +test namespace-6.4 {relative ns names only looked up in current ns} { + namespace delete tns1::tns2 + list [namespace eval tns1 $trigger] \ + [namespace eval tns1 $trigger2] +} {::tns1::tns2 ::tns1::tns2::test_ns_cache3} + +test namespace-6.5 {define test commands} { + proc testcmd {} { + return "global version" + } + namespace eval tns1 { + proc trigger {} { + testcmd + } + } + tns1::trigger +} {global version} + +test namespace-6.6 {one-level check for command shadowing} { + proc tns1::testcmd {} { + return "cache1 version" + } + tns1::trigger +} {cache1 version} + +test namespace-6.7 {renaming commands changes command epoch} { + namespace eval tns1 { + rename testcmd testcmd_new + } + tns1::trigger +} {global version} +test namespace-6.8 {renaming back handles shadowing} { + namespace eval tns1 { + rename testcmd_new testcmd + } + tns1::trigger +} {cache1 version} +test namespace-6.9 {deleting commands changes command epoch} { + namespace eval tns1 { + rename testcmd "" + } + tns1::trigger +} {global version} +test namespace-6.10 {define test namespaces} { + namespace eval tns2 { + proc testcmd {} { + return "global cache2 version" + } + } + namespace eval tns1 { + proc trigger {} { + tns2::testcmd + } + } + namespace eval tns1::tns2 { + proc trigger {} { + testcmd + } + } + list [tns1::trigger] [tns1::tns2::trigger] +} {{global cache2 version} {global version}} + +test namespace-6.11 {commands affect all parent namespaces} { + proc tns1::tns2::testcmd {} { + return "cache2 version" + } + list [tns1::trigger] [tns1::tns2::trigger] +} {{cache2 version} {cache2 version}} + +# ----------------------------------------------------------------------- +# TEST: uplevel/upvar across namespace boundaries +# ----------------------------------------------------------------------- +# Note that Tcl behaves a little differently for uplevel and upvar + +test namespace-7.1 {uplevel in namespace eval} jim { + set x 66 + namespace eval uns1 { + variable y 55 + set x 33 + uplevel 1 set x + } +} {66} + +test namespace-7.2 {upvar in ns proc} jim { + proc uns1::getvar {v} { + variable y + upvar $v var + list $var $y + } + uns1::getvar x +} {66 55} + +# ----------------------------------------------------------------------- +# TEST: scoped values +# ----------------------------------------------------------------------- +test namespace-10.1 {define namespace for scope test} { + namespace eval ins1 { + variable x "x-value" + proc show {args} { + return "show: $args" + } + proc do {args} { + return [eval $args] + } + list [set x] [show test] + } +} {x-value {show: test}} + +test namespace-10.2 {command "namespace code" requires one argument} { + list [catch {namespace code} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-10.3 {command "namespace code" requires one argument} { + list [catch {namespace code first "second arg" third} msg] $msg +} {1 {wrong # args: should be "namespace code arg"}} + +test namespace-10.4 {command "namespace code" gets current namesp context} { + namespace eval ins1 { + namespace code {"1 2 3" "4 5" 6} + } +} {::namespace inscope ::ins1 {"1 2 3" "4 5" 6}} + +test namespace-10.5 {with one arg, first "scope" sticks} { + set sval [namespace eval ins1 {namespace code {one two}}] + namespace code $sval +} {::namespace inscope ::ins1 {one two}} + +test namespace-10.6 {with many args, each "scope" adds new args} { + set sval [namespace eval ins1 {namespace code {one two}}] + namespace code "$sval three" +} {::namespace inscope ::ins1 {one two} three} + +test namespace-10.7 {scoped commands work with eval} { + set cref [namespace eval ins1 {namespace code show}] + list [eval $cref "a" "b c" "d e f"] +} {{show: a b c d e f}} + +test namespace-10.8 {scoped commands execute in namespace context} { + set cref [namespace eval ins1 { + namespace code {variable x; set x "some new value"} + }] + list [set ins1::x] [eval $cref] [set ins1::x] +} {x-value {some new value} {some new value}} + +test namespace-11.1 {command caching} { + proc cmd1 {} { return global } + set result {} + namespace eval ns1 { + proc cmd1 {} { return ns1 } + proc cmd2 {} { + uplevel 1 cmd1 + } + lappend ::result [cmd2] + } + lappend result [ns1::cmd2] +} {ns1 global} + +foreach cmd [info commands test_ns_*] { + rename $cmd "" +} + +catch {rename cmd {}} +catch {rename cmd1 {}} +catch {rename cmd2 {}} +catch {rename ncmd {}} +catch {rename ncmd1 {}} +catch {rename ncmd2 {}} +catch {unset cref} +catch {unset trigger} +catch {unset trigger2} +catch {unset sval} +catch {unset msg} +catch {unset x} +catch {unset test_ns_var_global} +catch {unset cmd} +catch {eval namespace delete [namespace children :: test_ns_*]} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: @@ -15,7 +15,7 @@ /** * Converts the given unicode codepoint (0 - 0x1fffff) to utf-8 * and stores the result at 'p'. - * + * * Returns the number of utf-8 characters (up to MAX_UTF8_LEN). */ int utf8_fromunicode(char *p, unsigned uc); |