summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog14
-rw-r--r--doc/namespace.n176
-rw-r--r--generic/tclBasic.c54
-rw-r--r--generic/tclInt.h191
-rw-r--r--generic/tclNamesp.c1606
-rw-r--r--generic/tclObj.c3
-rw-r--r--tests/namespace.test461
7 files changed, 2394 insertions, 111 deletions
diff --git a/ChangeLog b/ChangeLog
index c148f91..0809701 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,19 @@
2003-09-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+ TIP#112 IMPLEMENTATION
+
+ * generic/tclNamesp.c: Core of implementation.
+ * generic/tclInt.h (Namespace,TclInvalidateNsCmdLookup): Add
+ command list epoch counter and list of ensembles to namespace
+ structure, and define a macro to ease update of the epoch
+ counter.
+ * generic/tclBasic.c (Tcl_CreateObjCommand,etc.): Update epoch
+ counter when list of commands in a namespace changes.
+ * generic/tclObj.c (TclInitObjSubsystem): Register ensemble
+ subcommand type.
+ * tests/namespace.test (42.1-47.6): Tests.
+ * doc/namespace.n: Documentation.
+
* library/http/http.tcl (geturl): Correctly check the type of
boolean-valued options. [Bug 811170]
diff --git a/doc/namespace.n b/doc/namespace.n
index 932cdaa..48180d1 100644
--- a/doc/namespace.n
+++ b/doc/namespace.n
@@ -6,10 +6,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: namespace.n,v 1.10 2003/04/15 19:50:37 jenglish Exp $
+'\" RCS: @(#) $Id: namespace.n,v 1.11 2003/09/29 14:37:14 dkf Exp $
'\"
.so man.macros
-.TH namespace n 8.0 Tcl "Tcl Built-In Commands"
+.TH namespace n 8.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
@@ -87,6 +87,13 @@ looking it up by name.
If a namespace doesn't exist, this command returns an error.
If no namespace names are given, this command does nothing.
.TP
+\fBnamespace ensemble\fR \fIoption\fR ?\fIarg ...\fR?
+.VS 8.5
+Creates and manipulates a command that is formed out of an ensemble of
+subcommands. See the section \fBENSEMBLES\fR below for further
+details.
+.VE 8.5
+.TP
\fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR?
Activates a namespace called \fInamespace\fR and evaluates some code
in that context.
@@ -569,7 +576,7 @@ If a \fBnamespace import\fR command specifies a command
that is not exported, the command is not imported.
.SH "SCOPED SCRIPTS"
-The \fBnamespace code\fP command is the means by which a script may be
+The \fBnamespace code\fR command is the means by which a script may be
packaged for evaluation in a namespace other than the one in which it
was created. It is used most often to create event handlers, Tk bindings,
and traces for evaluation in the global context. For instance, the following
@@ -592,8 +599,167 @@ When executed, it prints the message:
the value of a::b has changed to c
.CE
+.SH ENSEMBLES
+.PP
+.VS 8.5
+The \fBnamespace ensemble\fR is used to create and manipulate ensemble
+commands, which are commands formed by grouping subcommands together.
+The commands typically come from the current namespace when the
+ensemble was created, though this is configurable. Note that there
+may be any number of ensembles associated with any namespace
+(including none, which is true of all namespaces by default), though
+all the ensembles associated with a namespace are deleted when that
+namespace is deleted. The link between an ensemble command and its
+namespace is maintained however the ensemble is renamed.
+.PP
+Three subcommands of the \fBnamespace ensemble\fR command are defined:
+.TP
+\fBnamespace ensemble create\fR ?\fIoption value ...\fR?
+Creates a new ensemble command linked to the current namespace,
+returning the fully qualified name of the command created. The
+arguments to \fBnamespace ensemble create\fR allow the configuration
+of the command as if with the \fBnamespace ensemble configure\fR
+command. If not overridden with the \fB\-command\fR option, this
+command creates an ensemble with exactly the same name as the linked
+namespace. See the section \fBENSEMBLE OPTIONS\fR below for a full
+list of options supported and their effects.
+.TP
+\fBnamespace ensemble configure \fIcommand\fR ?\fIoption\fR? ?\fIvalue ...\fR?
+Retrieves the value of an option associated with the ensemble command
+named \fIcommand\fR, or updates some options associated with that
+ensemble command. See the section \fBENSEMBLE OPTIONS\fR below for a
+full list of options supported and their effects.
+.TP
+\fBnamespace ensemble exists\fR \fIcommand\fR
+Returns a boolean value that describes whether the command
+\fIcommand\fR exists and is an ensemble command. This command only
+ever returns an error if the number of arguments to the command is
+wrong.
+.PP
+When called, an ensemble command takes its first argument and looks it
+up (according to the rules described below) to discover a list of
+words to replace the ensemble command and subcommand with. The
+resulting list of words is then evaluated (with no further
+substitutions) as if that was what was typed originally (i.e. by
+passing the list of words through \fBTcl_EvalObjv\fR) and returning
+the result of the command. Note that it is legal to make the target
+of an ensemble rewrite be another (or even the same) ensemble
+command. The ensemble command will not be visible through the use of
+the \fBuplevel\fR or \fBinfo level\fR commands.
+
+.SH "ENSEMBLE OPTIONS"
+.PP
+The following options, supported by the \fBnamespace ensemble
+create\fR and \fBnamespace ensemble configure\fR commands, control how
+an ensemble command behaves:
+.TP
+\fB\-map\fR
+When non-empty, this option supplies a dictionary that provides a
+mapping from subcommand names to a list of prefix words to substitute
+in place of the ensemble command and subcommand words (in a manner
+similar to an alias created with \fBinterp alias\fR; the words are not
+reparsed after substitution). When this option is empty, the mapping
+will be from the local name of the subcommand to its fully-qualified
+name. Note that when this option is non-empty and the
+\fB\-subcommands\fR option is empty, the ensemble subcommand names
+will be exactly those words that have mappings in the dictionary.
+.TP
+\fB\-prefixes\fR
+This option (which is enabled by default) controls whether the
+ensemble command recognizes unambiguous prefixes of its subcommands.
+When turned off, the ensemble command requires exact matching of
+subcommand names.
+.TP
+\fB\-subcommands\fR
+When non-empty, this option lists exactly what subcommands are in the
+ensemble. The mapping for each of those commands will either whatever
+is defined in the \fB\-map\fR option, or to the command with the same
+name in the namespace linked to the ensemble. If this option is
+empty, the subcommands of the namespace will either be the keys of the
+dictionary listed in the \fB\-map\fR option or the exported commands
+of the linked namespace at the time of the invokation of the ensemble
+command.
+.TP
+\fB\-unknown\fR
+When non-empty, this option provides a partial command (to which all
+the words that are arguments to the ensemble command, including the
+fully-qualified name of the ensemble, are appended) to handle the case
+where an ensemble subcommand is not recognized and would otherwise
+generate an error. When empty (the default) an error (in the style of
+\fBTcl_GetIndexFromObj\fR) is generated whenever the ensemble is
+unable to determine how to implement a particular subcommand. See
+\fBUNKNOWN HANDLER BEHAVIOUR\fR for more details.
+.PP
+The following extra option is allowed by \fBnamespace ensemble
+create\fR:
+.TP
+\fB\-command\fR
+This write-only option allows the name of the ensemble created by
+\fBnamespace ensemble create\fR to be anything in any existing
+namespace. The default value for this option is the fully-qualified
+name of the namespace in which the \fBnamespace ensemble create\fR
+command is invoked.
+.PP
+The following extra option is allowed by \fBnamespace ensemble
+configure\fR:
+.TP
+\fB\-namespace\fR
+This read-only option allows the retrieval of the fully-qualified name
+of the namespace which the ensemble was created within.
+
+.SH "UNKNOWN HANDLER BEHAVIOUR"
+.PP
+If an unknown handler is specified for an ensemble, that handler is
+called when the ensemble command would otherwise return an error due
+to it being unable to decide which subcommand to invoke. The exact
+conditions under which that occurs are controlled by the
+\fB\-subcommands\fR, \fB\-map\fR and \fB\-prefixes\fR options as
+described above.
+.PP
+To execute the unknown handler, the ensemble mechanism takes the
+specified \fB\-unknown\fR option and appends each argument of the
+attempted ensemble command invocation (including the ensemble command
+itself, expressed as a fully qualified name). It invokes the resulting
+command in the scope of the attempted call. If the execution of the
+unknown handler terminates normally, the ensemble engine reparses the
+subcommand (as described below) and tries to dispatch it again, which
+is ideal for when the ensemble's configuration has been updated by the
+unknown subcommand handler. Any other kind of termination of the
+unknown handler is treated as an error.
+.PP
+The result of the unknown handler is expected to be a list (it is an
+error if it is not). If the list is an empty list, the ensemble
+command attempts to look up the original subcommand again and, if it
+is not found this time, an error will be generated just as if the
+\fB\-unknown\fR handler was not there (i.e. for any particular
+invokation of an ensemble, its unknown handler will be called at most
+once.) This makes it easy for the unknown handler to update the
+ensemble or its backing namespace so as to provide an implementation
+of the desired subcommand and reparse.
+.PP
+When the result is a non-empty list, the words of that list are used
+to replace the ensemble command and subcommand, just as if they had
+been looked up in the \fB\-map\fR. It is up to the unknown handler to
+supply all namespace qualifiers if the implementing subcommand is not
+in the namespace of the caller of the ensemble command. Also note that
+when ensemble commands are chained (e.g. if you make one of the
+commands that implement an ensemble subcommand into an ensemble, in a
+manner similar to the text widget's tag and mark subcommands) then the
+rewrite happens in the context of the caller of the outermost
+ensemble. That is to say that ensembles do not in themselves place any
+namespace contexts on the Tcl call stack.
+.PP
+Where an empty \fB\-unknown\fR handler is given (the default), the
+ensemble command will generate an error message based on the list of
+commands that the ensemble has defined (formatted similarly to the
+error message from \fBTcl_GetIndexFromObj\fR). This is the error that
+will be thrown when the subcommand is still not recognized during
+reparsing. It is also an error for an \fB\-unknown\fR handler to
+delete its namespace.
+.VE 8.5
+
.SH "SEE ALSO"
-variable(n)
+interp(n), variable(n)
.SH KEYWORDS
-exported, internal, variable
+command, ensemble, exported, internal, variable
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 30e2165..8c1b739 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.86 2003/08/11 13:26:13 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.87 2003/09/29 14:37:14 dkf Exp $
*/
#include "tclInt.h"
@@ -1252,6 +1252,14 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
}
/*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just yet;
+ * next time we need the info will be soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
+
+ /*
* Now link the hash table entry with the command structure.
* We ensured above that the nsPtr was right.
*/
@@ -1381,6 +1389,14 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
}
/*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just yet;
+ * next time we need the info will be soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(nsPtr);
+
+ /*
* Remove the hash entry for the command from the interpreter hidden
* command table.
*/
@@ -1519,6 +1535,14 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
ckfree((char*) Tcl_GetHashValue(hPtr));
}
+ } else {
+ /*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just
+ * yet; next time we need the info will be soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(nsPtr);
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
@@ -1681,6 +1705,14 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
ckfree((char *) Tcl_GetHashValue(hPtr));
}
+ } else {
+ /*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just
+ * yet; next time we need the info will be soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(nsPtr);
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
@@ -2019,6 +2051,16 @@ TclRenameCommand(interp, oldName, newName)
}
/*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just yet;
+ * next time we need the info will be soon enough. These might
+ * refer to the same variable, but that's no big deal.
+ */
+
+ TclInvalidateNsCmdLookup(cmdNsPtr);
+ TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
+
+ /*
* Script for rename traces can delete the command "oldName".
* Therefore increment the reference count for cmdPtr so that
* it's Command structure is freed only towards the end of this
@@ -2463,7 +2505,15 @@ Tcl_DeleteCommandFromToken(interp, cmd)
}
cmdPtr->tracePtr = NULL;
}
-
+
+ /*
+ * The list of command exported from the namespace might have
+ * changed. However, we do not need to recompute this just yet;
+ * next time we need the info will be soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
+
/*
* If the command being deleted has a compile procedure, increment the
* interpreter's compileEpoch to invalidate its compiled code. This
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2be3ad1..d60429b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.132 2003/09/23 14:48:49 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.133 2003/09/29 14:37:14 dkf Exp $
*/
#ifndef _TCLINT
@@ -119,6 +119,8 @@ typedef struct Tcl_ResolverInfo {
*----------------------------------------------------------------
*/
+typedef struct Tcl_Ensemble Tcl_Ensemble;
+
/*
* The structure below defines a namespace.
* Note: the first five fields must match exactly the fields in a
@@ -127,91 +129,99 @@ typedef struct Tcl_ResolverInfo {
*/
typedef struct Namespace {
- char *name; /* The namespace's simple (unqualified)
- * name. This contains no ::'s. The name of
- * the global namespace is "" although "::"
- * is an synonym. */
- char *fullName; /* The namespace's fully qualified name.
- * This starts with ::. */
- ClientData clientData; /* An arbitrary value associated with this
- * namespace. */
+ char *name; /* The namespace's simple (unqualified)
+ * name. This contains no ::'s. The name of
+ * the global namespace is "" although "::"
+ * is an synonym. */
+ char *fullName; /* The namespace's fully qualified name.
+ * This starts with ::. */
+ ClientData clientData; /* An arbitrary value associated with this
+ * namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
- /* Procedure invoked when deleting the
- * namespace to, e.g., free clientData. */
- struct Namespace *parentPtr; /* Points to the namespace that contains
- * this one. NULL if this is the global
- * namespace. */
- Tcl_HashTable childTable; /* Contains any child namespaces. Indexed
- * by strings; values have type
- * (Namespace *). */
- long nsId; /* Unique id for the namespace. */
- Tcl_Interp *interp; /* The interpreter containing this
- * namespace. */
- int flags; /* OR-ed combination of the namespace
- * status flags NS_DYING and NS_DEAD
- * listed below. */
- int activationCount; /* Number of "activations" or active call
- * frames for this namespace that are on
- * the Tcl call stack. The namespace won't
- * be freed until activationCount becomes
- * zero. */
- int refCount; /* Count of references by namespaceName *
- * objects. The namespace can't be freed
- * until refCount becomes zero. */
- Tcl_HashTable cmdTable; /* Contains all the commands currently
- * registered in the namespace. Indexed by
- * strings; values have type (Command *).
- * Commands imported by Tcl_Import have
- * Command structures that point (via an
- * ImportedCmdRef structure) to the
- * Command structure in the source
- * namespace's command table. */
- Tcl_HashTable varTable; /* Contains all the (global) variables
- * currently in this namespace. Indexed
- * by strings; values have type (Var *). */
- char **exportArrayPtr; /* Points to an array of string patterns
- * specifying which commands are exported.
- * A pattern may include "string match"
- * style wildcard characters to specify
- * multiple commands; however, no namespace
- * qualifiers are allowed. NULL if no
- * export patterns are registered. */
- int numExportPatterns; /* Number of export patterns currently
- * registered using "namespace export". */
- int maxExportPatterns; /* Mumber of export patterns for which
- * space is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
- * shadows a command for which this
- * namespace has already cached a Command *
- * pointer; this causes all its cached
- * Command* pointers to be invalidated. */
- int resolverEpoch; /* Incremented whenever (a) the name resolution
- * rules change for this namespace or (b) a
- * newly added command shadows a command that
- * is compiled to bytecodes.
- * This invalidates all byte codes compiled
- * in the namespace, causing the code to be
- * recompiled under the new rules.*/
+ /* Procedure invoked when deleting the
+ * namespace to, e.g., free clientData. */
+ struct Namespace *parentPtr;/* Points to the namespace that contains
+ * this one. NULL if this is the global
+ * namespace. */
+ Tcl_HashTable childTable; /* Contains any child namespaces. Indexed
+ * by strings; values have type
+ * (Namespace *). */
+ long nsId; /* Unique id for the namespace. */
+ Tcl_Interp *interp; /* The interpreter containing this
+ * namespace. */
+ int flags; /* OR-ed combination of the namespace
+ * status flags NS_DYING and NS_DEAD
+ * listed below. */
+ int activationCount; /* Number of "activations" or active call
+ * frames for this namespace that are on
+ * the Tcl call stack. The namespace won't
+ * be freed until activationCount becomes
+ * zero. */
+ int refCount; /* Count of references by namespaceName *
+ * objects. The namespace can't be freed
+ * until refCount becomes zero. */
+ Tcl_HashTable cmdTable; /* Contains all the commands currently
+ * registered in the namespace. Indexed by
+ * strings; values have type (Command *).
+ * Commands imported by Tcl_Import have
+ * Command structures that point (via an
+ * ImportedCmdRef structure) to the
+ * Command structure in the source
+ * namespace's command table. */
+ Tcl_HashTable varTable; /* Contains all the (global) variables
+ * currently in this namespace. Indexed
+ * by strings; values have type (Var *). */
+ char **exportArrayPtr; /* Points to an array of string patterns
+ * specifying which commands are exported.
+ * A pattern may include "string match"
+ * style wildcard characters to specify
+ * multiple commands; however, no namespace
+ * qualifiers are allowed. NULL if no
+ * export patterns are registered. */
+ int numExportPatterns; /* Number of export patterns currently
+ * registered using "namespace export". */
+ int maxExportPatterns; /* Mumber of export patterns for which
+ * space is currently allocated. */
+ int cmdRefEpoch; /* Incremented if a newly added command
+ * shadows a command for which this
+ * namespace has already cached a Command *
+ * pointer; this causes all its cached
+ * Command* pointers to be invalidated. */
+ int resolverEpoch; /* Incremented whenever (a) the name resolution
+ * rules change for this namespace or (b) a
+ * newly added command shadows a command that
+ * is compiled to bytecodes.
+ * This invalidates all byte codes compiled
+ * in the namespace, causing the code to be
+ * recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
- /* If non-null, this procedure overrides
- * the usual command resolution mechanism
- * in Tcl. This procedure is invoked
- * within Tcl_FindCommand to resolve all
- * command references within the namespace. */
+ /* If non-null, this procedure overrides
+ * the usual command resolution mechanism
+ * in Tcl. This procedure is invoked
+ * within Tcl_FindCommand to resolve all
+ * command references within the namespace. */
Tcl_ResolveVarProc *varResProc;
- /* If non-null, this procedure overrides
- * the usual variable resolution mechanism
- * in Tcl. This procedure is invoked
- * within Tcl_FindNamespaceVar to resolve all
- * variable references within the namespace
- * at runtime. */
+ /* If non-null, this procedure overrides
+ * the usual variable resolution mechanism
+ * in Tcl. This procedure is invoked
+ * within Tcl_FindNamespaceVar to resolve all
+ * variable references within the namespace
+ * at runtime. */
Tcl_ResolveCompiledVarProc *compiledVarResProc;
- /* If non-null, this procedure overrides
- * the usual variable resolution mechanism
- * in Tcl. This procedure is invoked
- * within LookupCompiledLocal to resolve
- * variable references within the namespace
- * at compile time. */
+ /* If non-null, this procedure overrides
+ * the usual variable resolution mechanism
+ * in Tcl. This procedure is invoked
+ * within LookupCompiledLocal to resolve
+ * variable references within the namespace
+ * at compile time. */
+ int exportLookupEpoch; /* Incremented whenever a command is added to
+ * a namespace, removed from a namespace or
+ * the exports of a namespace are changed.
+ * Allows TIP#112-driven command lists to be
+ * validated efficiently. */
+ Tcl_Ensemble *ensembles; /* List of structures that contain the details
+ * of the ensembles that are implemented on
+ * top of this namespace. */
} Namespace;
/*
@@ -1570,6 +1580,7 @@ extern Tcl_ObjType tclStringType;
extern Tcl_ObjType tclArraySearchType;
extern Tcl_ObjType tclIndexType;
extern Tcl_ObjType tclNsNameType;
+extern Tcl_ObjType tclEnsembleCmdType;
extern Tcl_ObjType tclWideIntType;
/*
@@ -2275,12 +2286,28 @@ extern Tcl_Mutex tclObjMutex;
* CONST Tcl_UniChar *ct, unsigned long n));
*----------------------------------------------------------------
*/
+
#ifdef WORDS_BIGENDIAN
# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#else /* !WORDS_BIGENDIAN */
# define TclUniCharNcmp Tcl_UniCharNcmp
#endif /* WORDS_BIGENDIAN */
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to increment a namespace's export
+ * export epoch counter.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * EXTERN void TclInvalidateNsCmdLookup _ANSI_ARGS_((Namespace *nsPtr));
+ *----------------------------------------------------------------
+ */
+
+#define TclInvalidateNsCmdLookup(nsPtr) \
+ if ((nsPtr)->numExportPatterns) { \
+ (nsPtr)->exportLookupEpoch++; \
+ }
+
#include "tclIntDecls.h"
# undef TCL_STORAGE_CLASS
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 6961755..b09e5f2 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -5,11 +5,13 @@
* commands and global variables. The global :: namespace is the
* traditional Tcl "global" scope. Other namespaces are created as
* children of the global namespace. These other namespaces contain
- * special-purpose commands and variables for packages.
+ * special-purpose commands and variables for packages. Also includes
+ * the TIP#112 ensemble machinery.
*
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2002-2003 Donal K. Fellows.
*
* Originally implemented by
* Michael J. McLennan
@@ -19,7 +21,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.32 2003/06/18 18:30:01 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.33 2003/09/29 14:37:14 dkf Exp $
*/
#include "tclInt.h"
@@ -74,15 +76,110 @@ typedef struct ResolvedNsName {
} ResolvedNsName;
/*
+ * The client data for an ensemble command. This consists of the
+ * table of commands that are actually exported by the namespace, and
+ * an epoch counter that, combined with the exportLookupEpoch field of
+ * the namespace structure, defines whether the table contains valid
+ * data or will need to be recomputed next time the ensemble command
+ * is called.
+ */
+
+typedef struct EnsembleConfig {
+ Namespace *nsPtr; /* The namspace backing this ensemble up. */
+ Tcl_Command token; /* The token for the command that provides
+ * ensemble support for the namespace, or
+ * NULL if the command has been deleted (or
+ * never existed; the global namespace never
+ * has an ensemble command.) */
+ int epoch; /* The epoch at which this ensemble's table of
+ * exported commands is valid. */
+ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
+ * consistent points, this will have the same
+ * number of entries as there are entries in
+ * the subcommandTable hash. */
+ Tcl_HashTable subcommandTable;
+ /* Hash table of ensemble subcommand names,
+ * which are its keys so this also provides
+ * the storage management for those subcommand
+ * names. The contents of the entry values are
+ * object version the prefix lists to use when
+ * substituting for the command/subcommand to
+ * build the ensemble implementation command.
+ * Has to be stored here as well as in
+ * subcommandDict because that field is NULL
+ * when we are deriving the ensemble from the
+ * namespace exports list.
+ * FUTURE WORK: use object hash table here. */
+ struct EnsembleConfig *next;/* The next ensemble in the linked list of
+ * ensembles associated with a namespace. If
+ * this field points to this ensemble, the
+ * structure has already been unlinked from
+ * all lists, and cannot be found by scanning
+ * the list from the namespace's ensemble
+ * field. */
+ int flags; /* ORed combo of ENS_DEAD and ENS_PREFIX. */
+
+ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
+
+ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
+ * subcommands to their implementing command
+ * prefixes, or NULL if we are to build the
+ * map automatically from the namespace
+ * exports. */
+ Tcl_Obj *subcmdList; /* List of commands that this ensemble
+ * actually provides, and whose implementation
+ * will be built using the subcommandDict (if
+ * present and defined) and by simple mapping
+ * to the namespace otherwise. If NULL,
+ * indicates that we are using the (dynamic)
+ * list of currently exported commands. */
+ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
+ * no match is found (according to the rule
+ * defined by flag bit ENS_PREFIX) or NULL to
+ * use the default error-generating behaviour.
+ * The script execution gets all the arguments
+ * to the ensemble command (including objv[0])
+ * and will have the results passed directly
+ * back to the caller (including the error
+ * code) unless the code is TCL_CONTINUE in
+ * which case the subcommand will be reparsed
+ * by the ensemble core, presumably because
+ * the ensemble itself has been updated. */
+} EnsembleConfig;
+
+#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead
+ * and on its way out. */
+#define ENS_PREFIX 0x2 /* Flag value to say whether to allow
+ * unambiguous prefixes of commands or to
+ * require exact matches for command names. */
+
+/*
+ * The data cached in a subcommand's Tcl_Obj rep. This structure is
+ * not shared between Tcl_Objs referring to the same subcommand, even
+ * where one is a duplicate of another.
+ */
+
+typedef struct EnsembleCmdRep {
+ Namespace *nsPtr; /* The namespace backing the ensemble which
+ * this is a subcommand of. */
+ int epoch; /* Used to confirm when the data in this
+ * really structure matches up with the
+ * ensemble. */
+ char *fullSubcmdName; /* The full (local) name of the subcommand,
+ * allocated with ckalloc(). */
+ Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the
+ * command that implements this ensemble
+ * subcommand. */
+} EnsembleCmdRep;
+
+/*
* Declarations for procedures local to this file:
*/
-static void DeleteImportedCmd _ANSI_ARGS_((
- ClientData clientData));
+static void DeleteImportedCmd _ANSI_ARGS_((ClientData clientData));
static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
-static void FreeNsNameInternalRep _ANSI_ARGS_((
- Tcl_Obj *objPtr));
+static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int GetNamespaceFromObj _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Namespace **nsPtrPtr));
@@ -101,6 +198,9 @@ static int NamespaceCurrentCmd _ANSI_ARGS_((
static int NamespaceDeleteCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
+static int NamespaceEnsembleCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int NamespaceEvalCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
@@ -138,6 +238,22 @@ static int NamespaceWhichCmd _ANSI_ARGS_((
static int SetNsNameFromAny _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
+static int NsEnsembleImplementationCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+static void BuildEnsembleConfig _ANSI_ARGS_((
+ EnsembleConfig *ensemblePtr));
+static int NsEnsembleStringOrder _ANSI_ARGS_((CONST VOID *strPtr1,
+ CONST VOID *strPtr2));
+static void DeleteEnsembleConfig _ANSI_ARGS_((
+ ClientData clientData));
+static void MakeCachedEnsembleCommand _ANSI_ARGS_((
+ Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr,
+ CONST char *subcmdName, Tcl_Obj *prefixObjPtr));
+static void FreeEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void DupEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr));
+static void StringOfEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* This structure defines a Tcl object type that contains a
@@ -153,6 +269,21 @@ Tcl_ObjType tclNsNameType = {
UpdateStringOfNsName, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
+
+/*
+ * This structure defines a Tcl object type that contains a reference
+ * to an ensemble subcommand (e.g. the "length" in [string length ab])
+ * It is used to cache the mapping between the subcommand itself and
+ * the real command that implements it.
+ */
+
+Tcl_ObjType tclEnsembleCmdType = {
+ "ensembleCommand", /* the type's name */
+ FreeEnsembleCmdRep, /* freeIntRepProc */
+ DupEnsembleCmdRep, /* dupIntRepProc */
+ StringOfEnsembleCmdRep, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
/*
*----------------------------------------------------------------------
@@ -534,6 +665,8 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
nsPtr->cmdResProc = NULL;
nsPtr->varResProc = NULL;
nsPtr->compiledVarResProc = NULL;
+ nsPtr->exportLookupEpoch = 0;
+ nsPtr->ensembles = NULL;
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
@@ -604,6 +737,25 @@ Tcl_DeleteNamespace(namespacePtr)
Tcl_HashEntry *entryPtr;
/*
+ * If the namespace has associated ensemble commands, delete them
+ * first. This leaves the actual contents of the namespace alone
+ * (unless they are linked ensemble commands, of course.) Note
+ * that this code is actually reentrant so command delete traces
+ * won't purturb things badly.
+ */
+
+ while (nsPtr->ensembles != NULL) {
+ /*
+ * Splice out and link to indicate that we've already been
+ * killed.
+ */
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
+ ensemblePtr->next = ensemblePtr;
+ Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
+ }
+
+ /*
* If the namespace is on the call frame stack, it is marked as "dying"
* (NS_DYING is OR'd into its flags): the namespace can't be looked up
* by name but its commands and variables are still usable by those
@@ -939,6 +1091,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
}
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
+ TclInvalidateNsCmdLookup(nsPtr);
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
@@ -1008,6 +1161,16 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
+
+ /*
+ * The list of commands actually exported from the namespace might
+ * have changed (probably will have!) However, we do not need to
+ * recompute this just yet; next time we need the info will be
+ * soon enough.
+ */
+
+ TclInvalidateNsCmdLookup(nsPtr);
+
return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
@@ -2484,13 +2647,13 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
- "children", "code", "current", "delete",
+ "children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
"inscope", "origin", "parent", "qualifiers",
"tail", "which", (char *) NULL
};
enum NSSubCmdIdx {
- NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
+ NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
@@ -2525,6 +2688,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
case NSDeleteIdx:
result = NamespaceDeleteCmd(clientData, interp, objc, objv);
break;
+ case NSEnsembleIdx:
+ result = NamespaceEnsembleCmd(clientData, interp, objc, objv);
+ break;
case NSEvalIdx:
result = NamespaceEvalCmd(clientData, interp, objc, objv);
break;
@@ -3979,3 +4145,1427 @@ UpdateStringOfNsName(objPtr)
}
objPtr->length = length;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NamespaceEnsembleCmd --
+ *
+ * Invoked to implement the "namespace ensemble" command that
+ * creates and manipulates ensembles built on top of namespaces.
+ * Handles the following syntax:
+ *
+ * namespace ensemble name ?dictionary?
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * Creates the ensemble for the namespace if one did not
+ * previously exist. Alternatively, alters the way that the
+ * ensemble's subcommand => implementation prefix is configured.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NamespaceEnsembleCmd(dummy, interp, objc, objv)
+ ClientData dummy;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+{
+ Namespace *nsPtr;
+ EnsembleConfig *ensemblePtr;
+ static CONST char *subcommands[] = {
+ "configure", "create", "exists", NULL
+ };
+ enum EnsSubcmds {
+ ENS_CONFIG, ENS_CREATE, ENS_EXISTS
+ };
+ static CONST char *createOptions[] = {
+ "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL
+ };
+ enum EnsCreateOpts {
+ CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
+ };
+ static CONST char *configOptions[] = {
+ "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL
+ };
+ enum EnsConfigOpts {
+ CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN
+ };
+ int index;
+
+ nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_AppendResult(interp,
+ "tried to manipulate ensemble of deleted namespace", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum EnsSubcmds) index) {
+ case ENS_CREATE: {
+ char *name;
+ Tcl_DictSearch search;
+ Tcl_Obj *listObj, *nameObj = NULL;
+ int done, len, allocatedMapFlag = 0;
+ /*
+ * Defaults
+ */
+ Tcl_Obj *subcmdObj = NULL;
+ Tcl_Obj *mapObj = NULL;
+ int permitPrefix = 1;
+ Tcl_Obj *unknownObj = NULL;
+
+ objv += 3;
+ objc -= 3;
+
+ /*
+ * Work out what name to use for the command to create. If
+ * supplied, it is either fully specified or relative to the
+ * current namespace. If not supplied, it is exactly the name
+ * of the current namespace.
+ */
+
+ name = nsPtr->fullName;
+
+ /*
+ * Parse the option list, applying type checks as we go. Note
+ * that we are not incrementing any reference counts in the
+ * objects at this stage, so the presence of an option
+ * multiple times won't cause any memory leaks.
+ */
+
+ for (; objc>1 ; objc-=2,objv+=2 ) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
+ 0, &index) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsCreateOpts) index) {
+ case CRT_CMD:
+ name = TclGetString(objv[1]);
+ continue;
+ case CRT_SUBCMDS:
+ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CRT_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdObj;
+ /*
+ * Verify that the map is sensible.
+ */
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdObj, &listObj, &done) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ Tcl_Obj **listv;
+ char *cmd;
+
+ if (Tcl_ListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (len < 1) {
+ Tcl_SetResult(interp,
+ "ensemble subcommand implementations "
+ "must be non-empty lists", TCL_STATIC);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_NewListObj(len, listv);
+ Tcl_Obj *newCmd =
+ Tcl_NewStringObj(nsPtr->fullName, -1);
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
+ } while (!done);
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CRT_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ continue;
+ case CRT_UNKNOWN:
+ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ /*
+ * Make the name of the ensemble into a fully qualified name.
+ * This might allocate an object.
+ */
+
+ if (!(name[0] == ':' && name[1] == ':')) {
+ nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
+ if (nsPtr->parentPtr == NULL) {
+ Tcl_AppendStringsToObj(nameObj, name, NULL);
+ } else {
+ Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
+ }
+ Tcl_IncrRefCount(nameObj);
+ name = TclGetString(nameObj);
+ }
+
+ /*
+ * Create the ensemble. Note that this might delete another
+ * ensemble linked to the same namespace, so we must be
+ * careful. However, we should be OK because we only link the
+ * namespace into the list once we've created it (and after
+ * any deletions have occurred.)
+ */
+
+ ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig));
+ ensemblePtr->nsPtr = nsPtr;
+ ensemblePtr->epoch = 0;
+ Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
+ ensemblePtr->subcommandArrayPtr = NULL;
+ ensemblePtr->subcmdList = subcmdObj;
+ if (subcmdObj != NULL) {
+ Tcl_IncrRefCount(subcmdObj);
+ }
+ ensemblePtr->subcommandDict = mapObj;
+ if (mapObj != NULL) {
+ Tcl_IncrRefCount(mapObj);
+ }
+ ensemblePtr->flags = (permitPrefix ? ENS_PREFIX : 0);
+ ensemblePtr->unknownHandler = unknownObj;
+ if (unknownObj != NULL) {
+ Tcl_IncrRefCount(unknownObj);
+ }
+ ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
+ NsEnsembleImplementationCmd, (ClientData)ensemblePtr,
+ DeleteEnsembleConfig);
+ ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
+ /*
+ * Trigger an eventual recomputation of the ensemble command
+ * set. Note that this is slightly tricky, as it means that
+ * we are not actually counting the number of namespace export
+ * actions, but it is the simplest way to go!
+ */
+ nsPtr->exportLookupEpoch++;
+ Tcl_SetResult(interp, name, TCL_VOLATILE);
+ if (nameObj != NULL) {
+ Tcl_DecrRefCount(nameObj);
+ }
+ return TCL_OK;
+ }
+
+ case ENS_EXISTS: {
+ Command *cmdPtr;
+ int flag;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
+ return TCL_ERROR;
+ }
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, TclGetString(objv[3]), 0, 0);
+ flag = (cmdPtr != NULL &&
+ cmdPtr->objProc == NsEnsembleImplementationCmd);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), flag);
+ return TCL_OK;
+ }
+
+ case ENS_CONFIG: {
+ char *cmdName;
+ Command *cmdPtr;
+
+ if (objc < 4 || (objc != 5 && objc & 1)) {
+ Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
+ return TCL_ERROR;
+ }
+ cmdName = TclGetString(objv[3]);
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, cmdName, 0, TCL_LEAVE_ERR_MSG);
+ if (cmdPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_AppendResult(interp, cmdName, " is not an ensemble command",
+ NULL);
+ return TCL_ERROR;
+ }
+ ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
+
+ if (objc == 5) {
+ if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
+ 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_SetObjResult(interp, ensemblePtr->subcmdList);
+ }
+ break;
+ case CONF_MAP:
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_SetObjResult(interp, ensemblePtr->subcommandDict);
+ }
+ break;
+ case CONF_NAMESPACE:
+ Tcl_SetResult(interp, ensemblePtr->nsPtr->fullName,
+ TCL_VOLATILE);
+ break;
+ case CONF_PREFIX:
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX));
+ break;
+ case CONF_UNKNOWN:
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_SetObjResult(interp, ensemblePtr->unknownHandler);
+ }
+ break;
+ }
+ return TCL_OK;
+
+ } else if (objc == 4) {
+ /*
+ * Produce list of all information.
+ */
+
+ Tcl_Obj *resultObj;
+
+ TclNewObj(resultObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(configOptions[CONF_MAP], -1));
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ ensemblePtr->subcommandDict);
+ } else {
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1));
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewBooleanObj(ensemblePtr->flags & ENS_PREFIX));
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ ensemblePtr->subcmdList);
+ } else {
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
+ }
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ ensemblePtr->unknownHandler);
+ } else {
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ } else {
+ Tcl_DictSearch search;
+ Tcl_Obj *listObj;
+ int done, len, allocatedMapFlag = 0;
+ /*
+ * Defaults
+ */
+ Tcl_Obj *subcmdObj = ensemblePtr->subcmdList;
+ Tcl_Obj *mapObj = ensemblePtr->subcommandDict;
+ Tcl_Obj *unknownObj = ensemblePtr->unknownHandler;
+ int permitPrefix = ensemblePtr->flags & ENS_PREFIX;
+
+ objv += 4;
+ objc -= 4;
+
+ /*
+ * Parse the option list, applying type checks as we go.
+ * Note that we are not incrementing any reference counts
+ * in the objects at this stage, so the presence of an
+ * option multiple times won't cause any memory leaks.
+ */
+
+ for (; objc>0 ; objc-=2,objv+=2 ) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
+ "option", 0, &index) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CONF_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdObj;
+ /*
+ * Verify that the map is sensible.
+ */
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdObj, &listObj, &done) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ Tcl_Obj **listv;
+ char *cmd;
+
+ if (Tcl_ListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (len < 1) {
+ Tcl_SetResult(interp,
+ "ensemble subcommand implementations "
+ "must be non-empty lists", TCL_STATIC);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_NewListObj(len, listv);
+ Tcl_Obj *newCmd =
+ Tcl_NewStringObj(nsPtr->fullName, -1);
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdObj,
+ newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
+ } while (!done);
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CONF_NAMESPACE:
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ Tcl_AppendResult(interp, "option -namespace is read-only",
+ NULL);
+ return TCL_ERROR;
+ case CONF_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ continue;
+ case CONF_UNKNOWN:
+ if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ /*
+ * Update the namespace now that we've finished the
+ * parsing stage.
+ */
+
+ if (ensemblePtr->subcmdList != subcmdObj) {
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcmdList);
+ }
+ ensemblePtr->subcmdList = subcmdObj;
+ if (subcmdObj != NULL) {
+ Tcl_IncrRefCount(subcmdObj);
+ }
+ }
+ if (ensemblePtr->subcommandDict != mapObj) {
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcommandDict);
+ }
+ ensemblePtr->subcommandDict = mapObj;
+ if (mapObj != NULL) {
+ Tcl_IncrRefCount(mapObj);
+ }
+ }
+ if (ensemblePtr->unknownHandler != unknownObj) {
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->unknownHandler);
+ }
+ ensemblePtr->unknownHandler = unknownObj;
+ if (unknownObj != NULL) {
+ Tcl_IncrRefCount(unknownObj);
+ }
+ }
+ if (permitPrefix) {
+ ensemblePtr->flags |= ENS_PREFIX;
+ } else {
+ ensemblePtr->flags &= ~ENS_PREFIX;
+ }
+ /*
+ * Trigger an eventual recomputation of the ensemble
+ * command set. Note that this is slightly tricky, as it
+ * means that we are not actually counting the number of
+ * namespace export actions, but it is the simplest way to
+ * go! Also note that this nsPtr and ensemblePtr->nsPtr
+ * are quite possibly not the same namespace; we want to
+ * bump the epoch for the ensemble's namespace, not the
+ * current namespace.
+ */
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+ return TCL_OK;
+ }
+ }
+
+ default:
+ panic("unexpected ensemble command");
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleImplementationCmd --
+ *
+ * Implements an ensemble of commands (being those exported by a
+ * namespace other than the global namespace) as a command with
+ * the same (short) name as the namespace in the parent namespace.
+ *
+ * Results:
+ * A standard Tcl result code. Will be TCL_ERROR if the command
+ * is not an unambiguous prefix of any command exported by the
+ * ensemble's namespace.
+ *
+ * Side effects:
+ * Depends on the command within the namespace that gets executed.
+ * If the ensemble itself returns TCL_ERROR, a descriptive error
+ * message will be placed in the interpreter's result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleImplementationCmd(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+{
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
+ /* The ensemble itself. */
+ Tcl_Obj **tempObjv; /* Space used to construct the list of
+ * arguments to pass to the command
+ * that implements the ensemble
+ * subcommand. */
+ int result; /* The result of the subcommand
+ * execution. */
+ Tcl_Obj *prefixObj; /* An object containing the prefix
+ * words of the command that implements
+ * the subcommand. */
+ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
+ * specified but not yet cached command
+ * names. */
+ Tcl_Obj **prefixObjv; /* The list of objects to substitute in
+ * as the target command prefix. */
+ int prefixObjc; /* Size of prefixObjv of course! */
+ int reparseCount = 0; /* Number of reparses. */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
+ return TCL_ERROR;
+ }
+
+ restartEnsembleParse:
+ if (ensemblePtr->nsPtr->flags & NS_DEAD) {
+ /*
+ * Don't know how we got here, but make things give up quickly.
+ */
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_AppendResult(interp,
+ "ensemble activated for deleted namespace", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) {
+ ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
+ BuildEnsembleConfig(ensemblePtr);
+ } else {
+ /*
+ * Table of subcommands is still valid; therefore there might
+ * be a valid cache of discovered information which we can
+ * reuse. Do the check here, and if we're still valid, we can
+ * jump straight to the part where we do the invocation of the
+ * subcommand.
+ */
+
+ if (objv[1]->typePtr == &tclEnsembleCmdType) {
+ EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
+ objv[1]->internalRep.otherValuePtr;
+ if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
+ ensembleCmd->epoch == ensemblePtr->epoch) {
+ prefixObj = ensembleCmd->realPrefixObj;
+ goto runSubcommand;
+ }
+ }
+ }
+
+ /*
+ * Look in the hashtable for the subcommand name; this is the
+ * fastest way of all.
+ */
+
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
+ TclGetString(objv[1]));
+ if (hPtr != NULL) {
+ char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
+ prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
+ } else if (!(ensemblePtr->flags & ENS_PREFIX)) {
+ /*
+ * Can't find and we are prohibited from using unambiguous prefixes.
+ */
+ goto unknownOrAmbiguousSubcommand;
+ } else {
+ /*
+ * If we've not already confirmed the command with the hash as
+ * part of building our export table, we need to scan the
+ * sorted array for matches.
+ */
+
+ char *subcmdName; /* Name of the subcommand, or unique
+ * prefix of it (will be an error for
+ * a non-unique prefix). */
+ char *fullName = NULL; /* Full name of the subcommand. */
+ int stringLength, i;
+ int tableLength = ensemblePtr->subcommandTable.numEntries;
+
+ subcmdName = TclGetString(objv[1]);
+ stringLength = objv[1]->length;
+ for (i=0 ; i<tableLength ; i++) {
+ register int cmp = strncmp(subcmdName,
+ ensemblePtr->subcommandArrayPtr[i],
+ (unsigned)stringLength);
+ if (cmp == 0) {
+ if (fullName != NULL) {
+ /*
+ * Since there's never the exact-match case to
+ * worry about (hash search filters this), getting
+ * here indicates that our subcommand is an
+ * ambiguous prefix of (at least) two exported
+ * subcommands, which is an error case.
+ */
+ goto unknownOrAmbiguousSubcommand;
+ }
+ fullName = ensemblePtr->subcommandArrayPtr[i];
+ } else if (cmp == 1) {
+ /*
+ * Because we are searching a sorted table, we can now
+ * stop searching because we have gone past anything
+ * that could possibly match.
+ */
+ break;
+ }
+ }
+ if (fullName == NULL) {
+ /*
+ * The subcommand is not a prefix of anything, so bail out!
+ */
+ goto unknownOrAmbiguousSubcommand;
+ }
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
+ if (hPtr == NULL) {
+ panic("full name %s not found in supposedly synchronized hash",
+ fullName);
+ }
+ prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
+ }
+
+ runSubcommand:
+ /*
+ * Do the real work of execution of the subcommand by building an
+ * array of objects (note that this is potentially not the same
+ * length as the number of arguments to this ensemble command),
+ * populating it and then feeding it back through the main
+ * command-lookup engine. In theory, we could look up the command
+ * in the namespace ourselves, as we already have the namespace in
+ * which it is guaranteed to exist, but we don't do that (the
+ * cacheing of the command object used should help with that.)
+ */
+
+ Tcl_IncrRefCount(prefixObj);
+ runResultingSubcommand:
+ Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
+ tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc));
+ memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
+ memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+ result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, 0);
+ Tcl_DecrRefCount(prefixObj);
+ ckfree((char *)tempObjv);
+ return result;
+
+ unknownOrAmbiguousSubcommand:
+ /*
+ * Have not been able to match the subcommand asked for with a
+ * real subcommand that we export. See whether a handler has been
+ * registered for dealing with this situation. Will only call (at
+ * most) once for any particular ensemble invocation.
+ */
+
+ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
+ int paramc, i;
+ Tcl_Obj **paramv, *unknownCmd;
+ char *ensName = TclGetString(objv[0]);
+
+ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
+ if (ensName[0] == ':') {
+ Tcl_ListObjAppendElement(NULL, unknownCmd, objv[0]);
+ } else {
+ Tcl_Obj *qualEnsembleObj =
+ Tcl_NewStringObj(Tcl_GetCurrentNamespace(interp)->fullName,-1);
+ if (Tcl_GetCurrentNamespace(interp)->parentPtr) {
+ Tcl_AppendStringsToObj(qualEnsembleObj, "::", ensName, NULL);
+ } else {
+ Tcl_AppendStringsToObj(qualEnsembleObj, ensName, NULL);
+ }
+ Tcl_ListObjAppendElement(NULL, unknownCmd, qualEnsembleObj);
+ }
+ for (i=1 ; i<objc ; i++) {
+ Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
+ }
+ Tcl_ListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ Tcl_Preserve(ensemblePtr);
+ Tcl_IncrRefCount(unknownCmd);
+ result = Tcl_EvalObjv(interp, paramc, paramv, 0);
+ if (result == TCL_OK) {
+ prefixObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(prefixObj);
+ Tcl_DecrRefCount(unknownCmd);
+ Tcl_Release(ensemblePtr);
+ Tcl_ResetResult(interp);
+ if (ensemblePtr->flags & ENS_DEAD) {
+ Tcl_DecrRefCount(prefixObj);
+ Tcl_SetResult(interp,
+ "unknown subcommand handler deleted its ensemble",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Namespace is still there. Check if the result is a
+ * valid list. If it is, and it is non-empty, that list
+ * is what we are using as our replacement.
+ */
+
+ if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
+ Tcl_DecrRefCount(prefixObj);
+ Tcl_AddErrorInfo(interp,
+ "\n while parsing result of ensemble unknown subcommand handler");
+ return TCL_ERROR;
+ }
+ if (prefixObjc > 0) {
+ /*
+ * Not 'runSubcommand' because we want to get the
+ * object refcounting right.
+ */
+ goto runResultingSubcommand;
+ }
+
+ /*
+ * Namespace alive & empty result => reparse.
+ */
+
+ goto restartEnsembleParse;
+ }
+ if (!Tcl_InterpDeleted(interp)) {
+ if (result != TCL_ERROR) {
+ Tcl_ResetResult(interp);
+ Tcl_SetResult(interp,
+ "unknown subcommand handler returned bad code: ",
+ TCL_STATIC);
+ switch (result) {
+ case TCL_RETURN:
+ Tcl_AppendResult(interp, "return", NULL);
+ break;
+ case TCL_BREAK:
+ Tcl_AppendResult(interp, "break", NULL);
+ break;
+ case TCL_CONTINUE:
+ Tcl_AppendResult(interp, "continue", NULL);
+ break;
+ default: {
+ char buf[TCL_INTEGER_SPACE];
+ sprintf(buf, "%d", result);
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ }
+ Tcl_AddErrorInfo(interp,
+ "\n result of ensemble unknown subcommand handler: ");
+ Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ } else {
+ Tcl_AddErrorInfo(interp,
+ "\n (ensemble unknown subcommand handler)");
+ }
+ }
+ Tcl_DecrRefCount(unknownCmd);
+ Tcl_Release(ensemblePtr);
+ return TCL_ERROR;
+ }
+ /*
+ * Cannot determine what subcommand to hand off to, so generate a
+ * (standard) failure message. Note the one odd case compared
+ * with standard ensemble-like command, which is where a namespace
+ * has no exported commands at all...
+ */
+ Tcl_ResetResult(interp);
+ if (ensemblePtr->subcommandTable.numEntries == 0) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "unknown subcommand \"", TclGetString(objv[1]),
+ "\": namespace ", ensemblePtr->nsPtr->fullName,
+ " does not export any commands", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown ",
+ (ensemblePtr->flags & ENS_PREFIX ? "or ambiguous " : ""),
+ "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
+ if (ensemblePtr->subcommandTable.numEntries == 1) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ ensemblePtr->subcommandArrayPtr[0], NULL);
+ } else {
+ int i;
+ for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
+ }
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "or ", ensemblePtr->subcommandArrayPtr[i], NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeCachedEnsembleCommand --
+ *
+ * Cache what we've computed so far; it's not nice to repeatedly
+ * copy strings about. Note that to do this, we start by
+ * deleting any old representation that there was (though if it
+ * was an out of date ensemble rep, we can skip some of the
+ * deallocation process.)
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Alters the internal representation of the first object parameter.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr)
+ Tcl_Obj *objPtr;
+ EnsembleConfig *ensemblePtr;
+ CONST char *subcommandName;
+ Tcl_Obj *prefixObjPtr;
+{
+ register EnsembleCmdRep *ensembleCmd;
+ int length;
+
+ if (objPtr->typePtr == &tclEnsembleCmdType) {
+ ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr;
+ Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
+ ensembleCmd->nsPtr->refCount--;
+ if ((ensembleCmd->nsPtr->refCount == 0)
+ && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
+ NamespaceFree(ensembleCmd->nsPtr);
+ }
+ ckfree(ensembleCmd->fullSubcmdName);
+ } else {
+ /*
+ * Kill the old internal rep, and replace it with a brand new
+ * one of our own.
+ */
+ if ((objPtr->typePtr != NULL)
+ && (objPtr->typePtr->freeIntRepProc != NULL)) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
+ objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd;
+ objPtr->typePtr = &tclEnsembleCmdType;
+ }
+
+ /*
+ * Populate the internal rep.
+ */
+ ensembleCmd->nsPtr = ensemblePtr->nsPtr;
+ ensemblePtr->nsPtr->refCount++;
+ ensembleCmd->realPrefixObj = prefixObjPtr;
+ length = strlen(subcommandName)+1;
+ ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
+ memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
+ Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteEnsembleConfig --
+ *
+ * Destroys the data structure used to represent an ensemble.
+ * This is called when the ensemble's command is deleted (which
+ * happens automatically if the ensemble's namespace is deleted.)
+ * Maintainers should note that ensembles should be deleted by
+ * deleting their commands.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is (eventually) deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteEnsembleConfig(clientData)
+ ClientData clientData;
+{
+ EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
+ Namespace *nsPtr = ensemblePtr->nsPtr;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hEnt;
+
+ /*
+ * Unlink from the ensemble chain if it has not been marked as
+ * having been done already.
+ */
+
+ if (ensemblePtr->next != ensemblePtr) {
+ EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
+ if (ensPtr == ensemblePtr) {
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
+ } else {
+ while (ensPtr != NULL) {
+ if (ensPtr->next == ensemblePtr) {
+ ensPtr->next = ensemblePtr->next;
+ break;
+ }
+ ensPtr = ensPtr->next;
+ }
+ }
+ }
+
+ /*
+ * Mark the namespace as dead so code that uses Tcl_Preserve() can
+ * tell whether disaster happened anyway.
+ */
+
+ ensemblePtr->flags |= ENS_DEAD;
+
+ /*
+ * Kill the pointer-containing fields.
+ */
+
+ if (ensemblePtr->subcommandTable.numEntries != 0) {
+ ckfree((char *)ensemblePtr->subcommandArrayPtr);
+ }
+ hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
+ while (hEnt != NULL) {
+ Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hEnt);
+ Tcl_DecrRefCount(prefixObj);
+ hEnt = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcmdList);
+ }
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcommandDict);
+ }
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->unknownHandler);
+ }
+
+ /*
+ * Arrange for the structure to be reclaimed. Note that this is
+ * complex because we have to make sure that we can react sensibly
+ * when an ensemble is deleted during the process of initialising
+ * the ensemble (especially the unknown callback.)
+ */
+
+ Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildEnsembleConfig --
+ *
+ * Create the internal data structures that describe how an
+ * ensemble looks, being a hash mapping from the full command
+ * name to the Tcl list that describes the implementation prefix
+ * words, and a sorted array of all the full command names to
+ * allow for reasonably efficient unambiguous prefix handling.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Reallocates and rebuilds the hash table and array stored at
+ * the ensemblePtr argument. For large ensembles or large
+ * namespaces, this is a potentially expensive operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BuildEnsembleConfig(ensemblePtr)
+ EnsembleConfig *ensemblePtr;
+{
+ Tcl_HashSearch search; /* Used for scanning the set of
+ * commands in the namespace that
+ * backs up this ensemble. */
+ int i, j, isNew;
+ Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
+ Tcl_HashEntry *hPtr;
+
+ if (hash->numEntries != 0) {
+ /*
+ * Remove pre-existing table.
+ */
+ ckfree((char *)ensemblePtr->subcommandArrayPtr);
+ Tcl_DeleteHashTable(hash);
+ Tcl_InitHashTable(hash, TCL_STRING_KEYS);
+ }
+
+ /*
+ * See if we've got an export list. If so, we will only export
+ * exactly those commands, which may be either implemented by the
+ * prefix in the subcommandDict or mapped directly onto the
+ * namespace's commands.
+ */
+
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
+ int subcmdc;
+
+ Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
+ &subcmdv);
+ for (i=0 ; i<subcmdc ; i++) {
+ char *name = TclGetString(subcmdv[i]);
+
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+
+ /* Skip non-unique cases. */
+ if (!isNew) {
+ continue;
+ }
+ /*
+ * Look in our dictionary (if present) for the command.
+ */
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
+ &target);
+ if (target != NULL) {
+ Tcl_SetHashValue(hPtr, (ClientData) target);
+ Tcl_IncrRefCount(target);
+ continue;
+ }
+ }
+ /*
+ * Not there, so map onto the namespace. Note in this
+ * case that we do not guarantee that the command is
+ * actually there; that is the programmer's responsibility
+ * (or [::unknown] of course).
+ */
+ cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
+ if (ensemblePtr->nsPtr->parentPtr != NULL) {
+ Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
+ } else {
+ Tcl_AppendStringsToObj(cmdObj, name, NULL);
+ }
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ } else if (ensemblePtr->subcommandDict != NULL) {
+ /*
+ * No subcmd list, but we do have a mapping dictionary so we
+ * should use the keys of that. Convert the dictionary's
+ * contents into the form required for the ensemble's internal
+ * hashtable.
+ */
+ Tcl_DictSearch dictSearch;
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
+ &keyObj, &valueObj, &done);
+ while (!done) {
+ char *name = TclGetString(keyObj);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ Tcl_SetHashValue(hPtr, (ClientData) valueObj);
+ Tcl_IncrRefCount(valueObj);
+ Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
+ }
+ } else {
+ /*
+ * Discover what commands are actually exported by the
+ * namespace. What we have is an array of patterns and a hash
+ * table whose keys are the command names exported by the
+ * namespace (the contents do not matter here.) We must find
+ * out what commands are actually exported by filtering each
+ * command in the namespace against each of the patterns in
+ * the export list. Note that we use an intermediate hash
+ * table to make memory management easier, and because that
+ * makes exact matching far easier too.
+ *
+ * Suggestion for future enhancement: compute the unique
+ * prefixes and place them in the hash too, which should make
+ * for even faster matching.
+ */
+
+ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
+ for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
+ char *nsCmdName = /* Name of command in namespace. */
+ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
+
+ for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
+ if (Tcl_StringMatch(nsCmdName,
+ ensemblePtr->nsPtr->exportArrayPtr[i])) {
+ hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
+
+ /*
+ * Remember, hash entries have a full reference to
+ * the substituted part of the command (as a list)
+ * as their content!
+ */
+
+ if (isNew) {
+ Tcl_Obj *cmdObj, *cmdPrefixObj;
+
+ TclNewObj(cmdObj);
+ Tcl_AppendStringsToObj(cmdObj,
+ ensemblePtr->nsPtr->fullName,
+ (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
+ nsCmdName, NULL);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ break;
+ }
+ }
+ }
+ }
+
+ if (hash->numEntries == 0) {
+ ensemblePtr->subcommandArrayPtr = NULL;
+ return;
+ }
+
+ /*
+ * Create a sorted array of all subcommands in the ensemble; hash
+ * tables are all very well for a quick look for an exact match,
+ * but they can't determine things like whether a string is a
+ * prefix of another (not without lots of preparation anyway) and
+ * they're no good for when we're generating the error message
+ * either.
+ *
+ * We do this by filling an array with the names (we use the hash
+ * keys directly to save a copy, since any time we change the
+ * array we change the hash too, and vice versa) and running
+ * quicksort over the array.
+ */
+
+ ensemblePtr->subcommandArrayPtr = (char **)
+ ckalloc(sizeof(char *) * hash->numEntries);
+
+ /*
+ * Fill array from both ends as this makes us less likely to end
+ * up with performance problems in qsort(), which is good. Note
+ * that doing this makes this code much more opaque, but the naive
+ * alternatve:
+ *
+ * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
+ * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
+ * ensemblePtr->subcommandArrayPtr[i] =
+ * Tcl_GetHashKey(hash, &hPtr);
+ * }
+ *
+ * can produce long runs of precisely ordered table entries when
+ * the commands in the namespace are declared in a sorted fashion
+ * (an ordering some people like) and the hashing functions (or
+ * the command names themselves) are fairly unfortunate. By
+ * filling from both ends, it requires active malice (and probably
+ * a debugger) to get qsort() to have awful runtime behaviour.
+ */
+
+ i = 0;
+ j = hash->numEntries;
+ hPtr = Tcl_FirstHashEntry(hash, &search);
+ while (hPtr != NULL) {
+ ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ if (hPtr == NULL) {
+ break;
+ }
+ ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ if (hash->numEntries > 1) {
+ qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries,
+ sizeof(char *), NsEnsembleStringOrder);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleStringOrder --
+ *
+ * Helper function to compare two pointers to two strings for use
+ * with qsort().
+ *
+ * Results:
+ * -1 if the first string is smaller, 1 if the second string is
+ * smaller, and 0 if they are equal.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleStringOrder(strPtr1, strPtr2)
+ CONST VOID *strPtr1, *strPtr2;
+{
+ return strcmp(*(CONST char **)strPtr1, *(CONST char **)strPtr2);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeEnsembleCmdRep --
+ *
+ * Destroys the internal representation of a Tcl_Obj that has been
+ * holding information about a command in an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is deallocated. If this held the last reference to a
+ * namespace's main structure, that main structure will also be
+ * destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeEnsembleCmdRep(objPtr)
+ Tcl_Obj *objPtr;
+{
+ EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
+ objPtr->internalRep.otherValuePtr;
+
+ Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
+ ckfree(ensembleCmd->fullSubcmdName);
+ ensembleCmd->nsPtr->refCount--;
+ if ((ensembleCmd->nsPtr->refCount == 0)
+ && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
+ NamespaceFree(ensembleCmd->nsPtr);
+ }
+ ckfree((char *)ensembleCmd);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupEnsembleCmdRep --
+ *
+ * Makes one Tcl_Obj into a copy of another that is a subcommand
+ * of an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is allocated, and the namespace that the ensemble is
+ * built on top of gains another reference.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupEnsembleCmdRep(objPtr, copyPtr)
+ Tcl_Obj *objPtr, *copyPtr;
+{
+ EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
+ objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
+ ckalloc(sizeof(EnsembleCmdRep));
+ int length = strlen(ensembleCmd->fullSubcmdName);
+
+ copyPtr->typePtr = &tclEnsembleCmdType;
+ copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy;
+ ensembleCopy->nsPtr = ensembleCmd->nsPtr;
+ ensembleCopy->epoch = ensembleCmd->epoch;
+ ensembleCopy->nsPtr->refCount++;
+ ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
+ Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
+ ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
+ memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
+ (unsigned) length+1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringOfEnsembleCmdRep --
+ *
+ * Creates a string representation of a Tcl_Obj that holds a
+ * subcommand of an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object gains a string (UTF-8) representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StringOfEnsembleCmdRep(objPtr)
+ Tcl_Obj *objPtr;
+{
+ EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
+ objPtr->internalRep.otherValuePtr;
+ int length = strlen(ensembleCmd->fullSubcmdName);
+
+ objPtr->length = length;
+ objPtr->bytes = ckalloc((unsigned) length+1);
+ memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
+}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index de02962..a3f9447 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.49 2003/07/24 18:16:31 mdejong Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.50 2003/09/29 14:37:14 dkf Exp $
*/
#include "tclInt.h"
@@ -263,6 +263,7 @@ TclInitObjSubsystem()
Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclIndexType);
Tcl_RegisterObjType(&tclNsNameType);
+ Tcl_RegisterObjType(&tclEnsembleCmdType);
Tcl_RegisterObjType(&tclCmdNameType);
#ifdef TCL_COMPILE_STATS
diff --git a/tests/namespace.test b/tests/namespace.test
index d49f0ff..0a9343c 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: namespace.test,v 1.21 2002/06/22 04:19:47 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.22 2003/09/29 14:37:14 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -641,7 +641,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
-} {1 {bad option "wombat": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
@@ -748,7 +748,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
@@ -1184,23 +1184,458 @@ test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
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
-
-
+# Ensembles (TIP#112)
+test namespace-42.1 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 1}
+ namespace ensemble create
+ }
+ list [info command ns] [ns x] [namespace delete ns] [info command ns]
+} {ns 1 {} {}}
+test namespace-42.2 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 1}
+ namespace ensemble create
+ }
+ rename ns foo
+ list [info command foo] [foo x] [namespace delete ns] [info command foo]
+} {foo 1 {} {}}
+test namespace-42.3 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create
+ }
+ set result [list [ns x1] [ns x2]]
+ lappend result [catch {ns x} msg] $msg
+ rename ns {}
+ lappend result [info command ns::x1]
+ namespace delete ns
+ lappend result [info command ns::x1]
+} {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}}
+test namespace-42.4 {ensembles: basic} {
+ namespace eval ns {
+ namespace export y*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create
+ }
+ set result [list [catch {ns x} msg] $msg]
+ namespace delete ns
+ set result
+} {1 {unknown subcommand "x": namespace ::ns does not export any commands}}
+test namespace-42.5 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ set result [list [catch {ns x} msg] $msg]
+ namespace delete ns
+ set result
+} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}}
+test namespace-42.6 {ensembles: nested} {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {} {format 0}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]]
+ namespace delete ns
+ set result
+} {0 1 2 3}
+test namespace-42.7 {ensembles: nested} {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {} {list [info level] [info level 1]}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]]
+ namespace delete ns
+ set result
+} {{1 ::ns::x0::z} 1 2 3}
+test namespace-43.1 {ensembles: dict-driven} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create -map {a x1 b x2}
+ }
+ set result [list [catch {ns c} msg] $msg [namespace ensemble exists ns]]
+ rename ns {}
+ lappend result [namespace ensemble exists ns]
+} {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0}
+test namespace-43.2 {ensembles: dict-driven} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {args} {list 1 $args}
+ proc x2 {args} {list 2 [llength $args]}
+ namespace ensemble create -map {
+ a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .}
+ }
+ }
+ set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]]
+ namespace delete ns
+ set result
+} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}}
+set SETUP {
+ namespace eval ns {
+ namespace export a b
+ proc a args {format 1,[llength $args]}
+ proc b args {format 2,[llength $args]}
+ proc c args {format 3,[llength $args]}
+ proc d args {format 4,[llength $args]}
+ namespace ensemble create -subcommands {b c}
+ }
+}
+test namespace-43.3 {ensembles: list-driven} {
+ eval $SETUP
+ namespace delete ns
+} {}
+test namespace-43.4 {ensembles: list-driven} -setup $SETUP -body {
+ ns a foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
+test namespace-43.5 {ensembles: list-driven} -setup $SETUP -body {
+ ns b foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 2,5
+test namespace-43.6 {ensembles: list-driven} -setup $SETUP -body {
+ ns c foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 3,5
+test namespace-43.7 {ensembles: list-driven} -setup $SETUP -body {
+ ns d foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
+set SETUP {
+ namespace eval ns {
+ namespace export a b
+ proc a args {format 1,[llength $args]}
+ proc b args {format 2,[llength $args]}
+ proc c args {format 3,[llength $args]}
+ proc d args {format 4,[llength $args]}
+ namespace ensemble create -subcommands {b c} -map {c ::ns::d}
+ }
+}
+test namespace-43.8 {ensembles: list-and-map-driven} {
+ eval $SETUP
+ namespace delete ns
+} {}
+test namespace-43.9 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns a foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
+test namespace-43.10 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns b foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 2,5
+test namespace-43.11 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns c foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 4,5
+test namespace-43.12 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns d foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
+set SETUP {
+ namespace eval ns {
+ namespace export *
+ proc foo args {format bar}
+ proc spong args {format wibble}
+ namespace ensemble create -prefixes off
+ }
+}
+test namespace-43.13 {ensembles: turn off prefixes} {
+ eval $SETUP
+ namespace delete ns
+} {}
+test namespace-43.14 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns fo
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "fo": must be foo, or spong}
+test namespace-43.15 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns foo
+} -cleanup {namespace delete ns} -result bar
+test namespace-43.16 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns s
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "s": must be foo, or spong}
+test namespace-43.17 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns spong
+} -cleanup {namespace delete ns} -result wibble
+test namespace-44.1 {ensemble: errors} {
+ list [catch {namespace ensemble} msg] $msg
+} {1 {wrong # args: should be "namespace ensemble subcommand ?arg ...?"}}
+test namespace-44.2 {ensemble: errors} {
+ list [catch {namespace ensemble ?} msg] $msg
+} {1 {bad subcommand "?": must be configure, create, or exists}}
+test namespace-44.3 {ensemble: errors} {
+ namespace eval ns {
+ list [catch {namespace ensemble create -map x} msg] $msg
+ }
+} {1 {missing value to go with key}}
+test namespace-44.4 {ensemble: errors} {
+ namespace eval ns {
+ list [catch {namespace ensemble create -map {x {}}} msg] $msg
+ }
+} {1 {ensemble subcommand implementations must be non-empty lists}}
+test namespace-45.1 {ensemble: introspection} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {}
+ namespace ensemble create
+ set ::result [namespace ensemble configure ::ns]
+ }
+ namespace delete ns
+ set result
+} {-map {} -namespace ::ns -prefixes 1 -subcommands {} -unknown {}}
+test namespace-45.2 {ensemble: introspection} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {}
+ namespace ensemble create -map {A x}
+ set ::result [namespace ensemble configure ::ns -map]
+ }
+ namespace delete ns
+ set result
+} {A ::ns::x}
+test namespace-46.1 {ensemble: modification} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 123}
+ # Ensemble maps A->x
+ namespace ensemble create -command ns -map {A ::ns::x}
+ set ::result [list [namespace ensemble configure ns -map] [ns A]]
+ # Ensemble maps B->x
+ namespace ensemble configure ns -map {B ::ns::x}
+ lappend ::result [namespace ensemble configure ns -map] [ns B]
+ # Ensemble maps x->x
+ namespace ensemble configure ns -map {}
+ lappend ::result [namespace ensemble configure ns -map] [ns x]
+ }
+ namespace delete ns
+ set result
+} {{A ::ns::x} 123 {B ::ns::x} 123 {} 123}
+test namespace-46.2 {ensemble: ensembles really use current export list} {
+ namespace eval ns {
+ namespace export x1
+ proc x1 {} {format 1}
+ proc x2 {} {format 1}
+ namespace ensemble create
+ }
+ catch {ns ?} msg; set result [list $msg]
+ namespace eval ns {namespace export x*}
+ catch {ns ?} msg; lappend result $msg
+ rename ns::x1 {}
+ catch {ns ?} msg; lappend result $msg
+ namespace delete ns
+ set result
+} {{unknown or ambiguous subcommand "?": must be x1} {unknown or ambiguous subcommand "?": must be x1, or x2} {unknown or ambiguous subcommand "?": must be x2}}
+test namespace-46.3 {ensemble: implementation errors} {
+ namespace eval ns {
+ variable count 0
+ namespace ensemble create -map {
+ a {::lappend ::result}
+ b {::incr ::ns::count}
+ }
+ }
+ set result {}
+ lappend result [catch { ns } msg] $msg
+ ns a [ns b 10]
+ rename ns p
+ p a [p b 3000]
+ lappend result $ns::count
+ namespace delete ns
+ lappend result [info command p]
+} {1 {wrong # args: should be "ns subcommand ?argument ...?"} 10 3010 3010 {}}
+test namespace-46.4 {ensemble: implementation errors} {
+ namespace eval ns {
+ namespace ensemble create
+ }
+ set result [info command ns]
+ lappend result [catch {ns ?} msg] $msg
+ namespace delete ns
+ set result
+} {ns 1 {unknown subcommand "?": namespace ::ns does not export any commands}}
+test namespace-46.5 {ensemble: implementation errors} {
+ namespace eval ns {
+ namespace ensemble create -map {foo ::error}
+ }
+ list [catch {ns foo bar} msg] $msg $::errorInfo [namespace delete ns]
+} {1 bar {bar
+ while executing
+"::error bar"
+ invoked from within
+"ns foo bar"} {}}
+test namespace-46.6 {ensemble: implementation renames/deletes itself} {
+ namespace eval ns {
+ namespace ensemble create -map {to ::rename}
+ }
+ ns to ns foo
+ foo to foo bar
+ bar to bar spong
+ spong to spong {}
+ namespace delete ns
+} {}
+test namespace-46.7 {ensemble: implementation deletes its namespace} {
+ namespace eval ns {
+ namespace ensemble create -map {kill {::namespace delete}}
+ }
+ ns kill ns
+} {}
+test namespace-46.8 {ensemble: implementation deletes its namespace} {
+ namespace eval ns {
+ namespace export *
+ proc foo {} {
+ variable x 1
+ bar
+ # Tricky; what is the correct return value anyway?
+ info exist x
+ }
+ proc bar {} {
+ namespace delete [namespace current]
+ }
+ namespace ensemble create
+ }
+ list [ns foo] [info exist ns::x]
+} {1 0}
+test namespace-46.9 {ensemble: configuring really configures things} {
+ namespace eval ns {
+ namespace ensemble create -map {a a} -prefixes 0
+ }
+ set result [list [catch {ns x} msg] $msg]
+ namespace ensemble configure ns -map {b b}
+ lappend result [catch {ns x} msg] $msg
+ namespace delete ns
+ set result
+} {1 {unknown subcommand "x": must be a} 1 {unknown subcommand "x": must be b}}
+test namespace-47.1 {ensemble: unknown handler} {
+ set log {}
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ global log
+ if {[string match {[a-z]*} $subcmd]} {
+ lappend log "making $subcmd"
+ proc $subcmd args {
+ global log
+ lappend log "running [info level 0]"
+ llength $args
+ }
+ } else {
+ lappend log "unknown $subcmd - args = $args"
+ return -code error \
+ "unknown or protected subcommand \"$subcmd\""
+ }
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ set result {}
+ lappend result [catch {ns a b c} msg] $msg
+ lappend result [catch {ns a b c} msg] $msg
+ lappend result [catch {ns b c d} msg] $msg
+ lappend result [catch {ns c d e} msg] $msg
+ lappend result [catch {ns Magic foo bar spong wibble} msg] $msg
+ list $result [lsort [info commands ::ns::*]] $log [namespace delete ns]
+} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}}
+test namespace-47.2 {ensemble: unknown handler} {
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ error foobar
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
+} {1 foobar {foobar
+ while executing
+"error foobar"
+ (procedure "::ns::Magic" line 2)
+ invoked from within
+"::ns::Magic ::ns spong"
+ (ensemble unknown subcommand handler)
+ invoked from within
+"ns spong"} {}}
+test namespace-47.3 {ensemble: unknown handler} {
+ namespace eval ns {
+ variable count 0
+ namespace export {[a-z]*}
+ proc a {} {}
+ proc c {} {}
+ proc Magic {ensemble subcmd args} {
+ variable count
+ incr count
+ proc b {} {}
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $ns::count [namespace delete ns]
+} {1 {unknown or ambiguous subcommand "spong": must be a, b, or c} 1 {}}
+test namespace-47.4 {ensemble: unknown handler} {
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ return -code break
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
+} {1 {unknown subcommand handler returned bad code: break} {unknown subcommand handler returned bad code: break
+ result of ensemble unknown subcommand handler: ::ns::Magic ::ns spong
+ invoked from within
+"ns spong"} {}}
+test namespace-47.5 {ensemble: unknown handler} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ global result target
+ lappend result "LOG $args"
+ return $target
+ }
+ set result {}
+ set target {}
+ lappend result [catch {foo bar} msg] $msg
+ set target {lappend result boo hoo}
+ lappend result [catch {foo bar} msg] $msg [namespace ensemble config foo]
+ rename foo {}
+ set result
+} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}}
+test namespace-47.6 {ensemble: unknown handler} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ return "\{"
+ }
+ set result [list [catch {foo bar} msg] $msg $errorInfo]
+ rename foo {}
+ set result
+} {1 {unmatched open brace in list} {unmatched open brace in list
+ while parsing result of ensemble unknown subcommand handler
+ invoked from within
+"foo bar"}}
+# cleanup
+catch {rename cmd1 {}}
+catch {unset l}
+catch {unset msg}
+catch {unset trigger}
+eval namespace delete [namespace children :: test_ns_*]
+::tcltest::cleanupTests
+return
generated by cgit v0.12 at 2024-11-01 11:15:27 (GMT)