ANN: majorminor.tcl - add subcommands easily in pure Tcl

1 view
Skip to first unread message

Alexandre Ferrieux

unread,
May 5, 1999, 3:00:00 AM5/5/99
to
Here: http://place.net/~af/tcl/majorminor.tcl is a sample pure-Tcl
implementation of a new command lookup mechanism ('major/minor')
described perviously at
http://www.dejanews.com/[ST_rn=ps]/getdoc.xp?AN=472294276.

See the description below.

Like for the previous 'curry' package, I am posting it here at a very
early stage both for feedback and as a potential incentive for
core-patchers to reimplement it with the best performance. In the
meantime, this simple standalone sourceable script will let people
validate/invalidate the semantics.

# Principle:

# This package aims at easing the process of overriding tcl
# subcommands. It does so by silently replacing overridden commands
# by a wrapper that tries to match arguments against the prefixes
# given by the programmer as special cases (cmd subcmd subsubcmd...).
# These prefixes are scanned by decreasing length, so that in case of
# conflict the most specific wins:

# % proc foo {x y} {puts "Generic foo: $x $y"}
# % subproc "foo bar baz" {} {puts AAA}
# % subproc "foo bar" z {puts BBB}
# % foo 3 4
# Generic foo: 3 4
# % foo bar 2
# BBB
# % foo bar baz
# AAA

# Performance issue: of course, the wrapper adds overhead to the
# non-overridden case. Worse, if you override "string compare" you'll
# disable the inlining of [string ...] by the byte compiler, so the
# overall effect will be awful. However:
# - in most cases (non-inlined procedures) this overhead will be
# bearable.
# - this script is provided only as a proof of concept. The aim
# is of course a core patch (once the semantics is agreed
# upon).

# As it is often witnessed in overriding frameworks (like OO), it is
# often handy to be able to call the unmodified "inherited" behavior
# within you overriding procedure. To do this, the [inherited] call is
# provided:

# % subproc "string compare" {x y} {
# puts stderr "I've been here !"
# inherited string compare $x $y
# }

# More generally, in a [subproc "a b c d e" ...] one is expected to
# to call [inherited "a b c d" e ...] to avoid unwanted recursion.

-Alex

Bruce S. O. Adams

unread,
May 5, 1999, 3:00:00 AM5/5/99
to

Alexandre Ferrieux wrote:

This is an interesting idea. In my introspection package, which I hope to finally

release as an alpha (because only the TCL version is ready and the API is up for
discussion,
the TCL is hopefully beta quality) by the weekend (assuming I can get my arse in
gear) I use a slightly
different scheme. Firstly I assume that there will only ever be one level of
subcommanding
as I have seen no further levels in code I have looked at, and switches are
generally preferred. If this
assumption proves to be faulty the mechanism could be extended. My basic scheme is
to override
the command with something like the following (ignoring namespaces for brevity):

rename info info_builtin

proc info { subcommand args } {
switch -exact -- $subcommand {
case allcommands: {
info_allcommands $args
}
...
default: {
info_builtin $subcommand $args
}
}
}

I have two routines addsubcommand and removesubcommand (which also allows
undesirable commands,
should such a thing exist, to be stubbed out). In C this will probably become
some kind of jump
table. I wonder which mechanism is best in terms of overhead and features?
By the way, did you know (excuse me if I this is patronising) that you can
do the following:

set fred "space proc"

proc $fred { } {
puts "ping"
}

$fred

Of course this won't work in an eval directly. I'm sure there are ways around
this though.
Regards,
Bruce A.


Marco R. Gazzetta

unread,
May 5, 1999, 3:00:00 AM5/5/99
to
Hi, Alexandre!

I think yours is a really neat tool, short and useful. My company has the
problem all the time of having to redefine the behavior of Tcl (and Tk)
commands, and there is at least one major package (incr Tcl) that had to
change its syntax in order not to muck around with the Tcl core.

The funny thing is that Tcl provides all the needed structures to implement
the behaviors we are asking for. Nothing prevents us from storing the
argument count of a proc in the HashTable that stores them, thus making
overriding procedure definitions easier. It wouldn't be all too difficult to
add a subcommand creation facility not unlike the one given for command
creation...

I guess the only real disadvantage of your solution is the performance hit it
gives us. If I add, say, a rotate subcommand to the canvas and have to perform
the rotation on a selected set of items, the slowdown will be more than
noticeable.

I noticed that you didn't care at all for namespace resolution in your code.
Is this intended?

Thanks for this neat tool,

Marco

In article <373053...@cnet.francetelecom.fr>,

-----------== Posted via Deja News, The Discussion Network ==----------
http://www.dejanews.com/ Search, Read, Discuss, or Start Your Own

James Ingham

unread,
May 5, 1999, 3:00:00 AM5/5/99
to
Marco,

Alexandre's tool looks fine, and there are circumstances where a pure
Tcl implementation is desirable. However, if you use IncrTcl, then
the same facility is already available, implemented in C. Look at the
"ensemble" command.

Michael offered this to the Tcl guys when he donated the original
namespace code, but it was deemed unnecessary, and was not adopted.
IncrTcl uses it extensively, so it has been pretty well tested. It is
also self-contained, so it would not be hard to hack it out of IncrTcl
and use it as a stand-alone library, if you wanted to do that.

Jim
--
++==++==++==++==++==++==++==++==++==++==++==++==++==++==++==++==++==++==++
Jim Ingham jin...@cygnus.com
Cygnus Solutions Inc.

Marco R. Gazzetta

unread,
May 5, 1999, 3:00:00 AM5/5/99
to
Well,

We extensively use [incr Tcl] ourselves, but even ensembles don't save our
soul... We have a highly performance optimized CAD tool, and the overhead of
creating an ensemble for every single widget command is not acceptable.

Correct me if I'm wrong: Our canvases have a "print" subcommand. For it to be
available in an ensemble world, I'd have to (a) create a (plain) canvas,
[canvas .c] (b) create an ensemble [ensemble ens.c { part postscript args
{#retrieve widget name and do postscript} part print args {#retrieve widget
name and do printing} ...] (c) change the code to teach it to use the
ensemble instead of the widget name.

This is based on the assumption that there is no easy way to rename a widget
while keeping its window qualities (that is, if I do a rename .c foo, pack foo
will fail).

I guess what I'd prefer is that selected commands, especially widgets
commands, should be extensible, just like Tcl itself is. Say I generated a
text widget import extension. Wouldn't I want to be able to tie directly to
the text widget, instead of having to work around with an ensemble?

After all, that's what makes Tcl a flexible language... And, again, all we
need is an extra HashTable in the Interpreter structure that stores a linked
list of subcommand handlers and a new subcommand creation API.

Looking forward to your ideas/comments,

Marco

In article <mfzp3jb...@leda.cygnus.com>,

-----------== Posted via Deja News, The Discussion Network ==----------

James Ingham

unread,
May 5, 1999, 3:00:00 AM5/5/99
to
Marco,

You are right about the current state of things. Michael's original
idea (IIRC) was to implement all the Tcl commands that it seems
reasonable to extend AS ensembles, and then this would be exactly what
you want. John et al balked at the confusion this might engender, as
people generated Tcl variants with all sorts of different subcommands.
There is some merit to this concern, but I am not sure it would
outweigh the benefits...

Sounds like you will need to hack into Tk for your purposes...

Alexandre Ferrieux

unread,
May 6, 1999, 3:00:00 AM5/6/99
to
Bruce S. O. Adams wrote:

>
> Alexandre Ferrieux wrote:
>
> > Here: http://place.net/~af/tcl/majorminor.tcl is a sample pure-Tcl
> > implementation of a new command lookup mechanism ('major/minor')
> > described perviously at
> > http://www.dejanews.com/[ST_rn=ps]/getdoc.xp?AN=472294276.
>
> In my introspection package, I use a slightly
> different scheme.
>
> rename info info_builtin
>
> proc info { subcommand args } {
> switch -exact -- $subcommand {
> case allcommands: {
> info_allcommands $args
> }
> ...
> default: {
> info_builtin $subcommand $args
> }
> }
> }
>
> I have two routines addsubcommand and removesubcommand

Basically my stuff does this in a more generic way (eg subsubcommands),
and also automates the 'rename' part :).
One note about subsubcommands: as such they are very seldom used;
however, the same mechanism applies to *any* fixed argument. So you can
define a special 'subsubcommand' to handle a given object as opposed to
all others:

subproc "file delete /tmp/toto" {} {
error "I'm sorry Dave. I'm afraid I can't do that."
}

> In C this will probably become
> some kind of jump
> table.

Yes. In my sample I scan on (decreasing) prefix length, then hash on the
prefix (string repr of the list)...

> I wonder which mechanism is best in terms of overhead and features?

I posted to get answers to this question in the first place :)

> By the way, did you know (excuse me if I this is patronising)
> that you can do the following:
>
> set fred "space proc"
>
> proc $fred { } {
> puts "ping"
> }
>
> $fred

Yes. I especially took care of this one (by preventing it!) in the
curry.tcl package I posted yesterday.

-Alex

Alexandre Ferrieux

unread,
May 6, 1999, 3:00:00 AM5/6/99
to
Marco R. Gazzetta wrote:
>
> I guess the only real disadvantage of your solution is the performance hit it
> gives us.

Yes. See my posting:

"as a potential incentive for core-patchers to reimplement it
with the best performance"

:)

> I noticed that you didn't care at all for namespace resolution in your code.
> Is this intended?

Yes. For two main reasons:

1) as said above, a proof-of-concept doesn't need the
bells-and-whistles.

2) I have little experience with namespaces, and I understand
they are not so well done as they could have been (see
Python's modules for a better design). I don't want to waste a
nanosecond on them:)

> Thanks for this neat tool,

Thank you very much for your feedback,

-Alex

Alexandre Ferrieux

unread,
May 6, 1999, 3:00:00 AM5/6/99
to
Marco R. Gazzetta wrote:
>
> change the code to teach it to use the
> ensemble instead of the widget name.
>
> This is based on the assumption that there is no easy way to rename a widget
> while keeping its window qualities (that is, if I do a rename .c foo, pack foo
> will fail).

The assumption is partly true. Granted, if you *only* rename .c to
something else (thus effectively removing the ".c" command), of course
internal Tk calls staring with ".c" will suffer... However, if you
rename it to override it, *and* call the old behavior as needed,
evrything works.

For example, with my sample slow implementation:

subproc ".t insert" args {
puts stderr "INSERTING: $args"
uplevel inherited .t insert $args
}

So I don't see why you couldn't do that with an ensemble. Or do I miss
something ?



> After all, that's what makes Tcl a flexible language... And, again, all we
> need is an extra HashTable in the Interpreter structure that stores a linked
> list of subcommand handlers and a new subcommand creation API.

Yes !!! I could not have expressed better what my sample is trying to
convince core-patchers to write...

-Alex

Paul Duffin

unread,
May 6, 1999, 3:00:00 AM5/6/99
to
Marco R. Gazzetta wrote:
>
> Well,
>
> We extensively use [incr Tcl] ourselves, but even ensembles don't save our
> soul... We have a highly performance optimized CAD tool, and the overhead of
> creating an ensemble for every single widget command is not acceptable.
>
> Correct me if I'm wrong: Our canvases have a "print" subcommand. For it to be
> available in an ensemble world, I'd have to (a) create a (plain) canvas,
> [canvas .c] (b) create an ensemble [ensemble ens.c { part postscript args
> {#retrieve widget name and do postscript} part print args {#retrieve widget
> name and do printing} ...] (c) change the code to teach it to use the

> ensemble instead of the widget name.
>
> This is based on the assumption that there is no easy way to rename a widget
> while keeping its window qualities (that is, if I do a rename .c foo, pack foo
> will fail).
>
> I guess what I'd prefer is that selected commands, especially widgets
> commands, should be extensible, just like Tcl itself is. Say I generated a
> text widget import extension. Wouldn't I want to be able to tie directly to
> the text widget, instead of having to work around with an ensemble?
>

In my soon to be released extension Feather I have added the ability to
override a command without renaming it so you can do things like

proc overridden_canvas {original subcommand args} {
switch -- $subcommand {
"print" {
puts "Print"
}

default {
return [invoke $original [list $subcommand] $args]
}
}
}

canvas .c
set original [command override .c]
command set .c [curry overridden_canvas $original]
.c print

--
Paul Duffin
DT/6000 Development Email: pdu...@hursley.ibm.com
IBM UK Laboratories Ltd., Hursley Park nr. Winchester
Internal: 7-246880 International: +44 1962-816880

Marco R. Gazzetta

unread,
May 6, 1999, 3:00:00 AM5/6/99
to

> > After all, that's what makes Tcl a flexible language... And, again, all we
> > need is an extra HashTable in the Interpreter structure that stores a linked
> > list of subcommand handlers and a new subcommand creation API.
>
> Yes !!! I could not have expressed better what my sample is trying to
> convince core-patchers to write...
>
> -Alex
>

Alex,

I couldn't resist the temptation and I'm attaching a patch file (it's against
the CVS repository as of end of March). I know the wrath of the modem
downloader will eventually hit me, but my flesh is weak, and my internet
connection fast. I apologize to everybody who didn't want to download these
500 lines - please, don't mass-mail me!!! I promise I won't do this again!

What the patch does is:

(a) adds an API call Tcl_CreateSubCmdHandler() that is closely mimicking
Tcl_CreateCommand (b) modifies the Interpreter structure to add a SubCmdTable
HashTable, where the SubCmdHandlers are stored (c) modifies the Tcl "info"
command to handle the new API. This is the core of the patch and shows
exactly how easy to implement such a change would be. All it requires is
thirteen lines of code - code that can be simply copied into any other
command (or -even better - we could make it a centralized function...) (d)
shows how to create a subCmdHandler by actually creating two of them. One is
created at first invocation of the "time" command, the other at the first
invocation of the "scan" command.

(d) is really the ugliest part of this. It replaces the Real Thing (TM),
which would be an extension that augments the info command (like Mike
McLennan used to do in Itcl)

Have fun with it and tell me what you think about it,

Marco

Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/generic/tcl.decls,v
retrieving revision 1.7
diff -c -r1.7 tcl.decls
*** tcl.decls 1999/03/11 02:49:33 1.7
--- tcl.decls 1999/05/06 16:13:30
***************
*** 973,978 ****
--- 973,982 ----
# }
# declare 285 generic {
# }
+ declare 286 generic {
+ void Tcl_CreateSubCmdHandler(Tcl_Interp *interp, char *cmdname,
+ Tcl_SubCmdHandler *proc, ClientData clientData)
+ }


#############################################################################
#

Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/generic/tcl.h,v
retrieving revision 1.38
diff -c -r1.38 tcl.h
*** tcl.h 1999/03/12 23:03:51 1.38
--- tcl.h 1999/05/06 16:13:31
***************
*** 412,417 ****
--- 412,419 ----
Tcl_Interp *interp));
typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
+ typedef int (Tcl_SubCmdHandler) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objects, int argc, ClientData vector));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/generic/tclBasic.c,v
retrieving revision 1.18
diff -c -r1.18 tclBasic.c
*** tclBasic.c 1999/03/11 02:49:34 1.18
--- tclBasic.c 1999/05/06 16:13:33
***************
*** 319,324 ****
--- 319,325 ----
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->errorLine = 0;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&iPtr->subCmdTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = 1000;
iPtr->framePtr = NULL;
***************
*** 831,836 ****
--- 832,845 ----
ckfree((char *) Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(&iPtr->mathFuncTable);
+
+ /* Same for subCmd Table */
+ for (hPtr = Tcl_FirstHashEntry(&iPtr->subCmdTable, &search);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ckfree((char *) Tcl_GetHashValue(hPtr));
+ }
+ Tcl_DeleteHashTable(&iPtr->subCmdTable);

/*
* Invoke deletion callbacks; note that a callback can create new
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/generic/tclCmdIL.c,v
retrieving revision 1.11
diff -c -r1.11 tclCmdIL.c
*** tclCmdIL.c 1999/02/03 00:55:04 1.11
--- tclCmdIL.c 1999/05/06 16:13:37
***************
*** 366,371 ****
--- 366,384 ----
result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
(int *) &index);
if (result != TCL_OK) {
+ Tcl_HashEntry *hPtr;
+ hPtr = Tcl_FindHashEntry(Tcl_GetSubCmdTable(interp),
+ Tcl_GetStringFromObj(objv[0], NULL));
+ if (hPtr) {
+ int retVal;
+ SubCmdProc *loopPtr;
+ SubCmdProc *subCmdPtr = (SubCmdProc *)Tcl_GetHashValue(hPtr);
+ for (loopPtr = subCmdPtr; loopPtr; loopPtr = loopPtr->next) {
+ retVal = (loopPtr->proc) (clientData, interp, 1, objc,
+ (ClientData) objv);
+ if (retVal != TCL_CONTINUE) return retVal;
+ }
+ }
return result;
}

Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.2
diff -c -r1.2 tclCmdMZ.c
*** tclCmdMZ.c 1998/09/14 18:39:57 1.2
--- tclCmdMZ.c 1999/05/06 16:13:38
***************
*** 43,48 ****
--- 43,119 ----
static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *name1, char *name2,
int flags));
+ static int
+ Tcl_TestHandlerProc(clientData, interp, objects, argc, vector)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objects;
+ int argc;
+ ClientData vector;
+ {
+ char **argv = NULL;
+ Tcl_Obj **objv = NULL;
+
+ char *name = NULL, *subcmd = NULL;
+
+ if (objects) {
+ objv = (Tcl_Obj **)vector;
+ subcmd = Tcl_GetStringFromObj(objv[1], NULL);
+ if (strcmp(subcmd, "extension") == 0) {
+ if (argc < 3) {
+ return TCL_ERROR;
+ }
+ name = Tcl_GetStringFromObj(objv[2], NULL);
+ switch (name[0]) {
+ case 'm' : Tcl_SetResult(interp, "371", TCL_STATIC); break;
+ case 'd' : Tcl_SetResult(interp, "715", TCL_STATIC); break;
+ default: Tcl_SetResult(interp, "unknown name", TCL_STATIC); return
TCL_ERROR;
+ }
+ return TCL_OK;
+ } else if (strcmp(subcmd, "nameofext") == 0) {
+ if (argc < 3) {
+ return TCL_ERROR;
+ }
+ name = Tcl_GetStringFromObj(objv[2], NULL);
+ if (strcmp(name, "371")) {
+ Tcl_SetResult(interp, "marco", TCL_STATIC);
+ } else if (strcmp(name, "715")) {
+ Tcl_SetResult(interp, "david", TCL_STATIC);
+ } else {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+ } else {
+ argv = (char **)vector;
+ }
+
+ return TCL_CONTINUE;
+ }
+
+ static int
+ Tcl_TestHandlerProc2(clientData, interp, objects, argc, vector)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objects;
+ int argc;
+ ClientData vector;
+ {
+ char **argv = NULL;
+ Tcl_Obj **objv = NULL;
+ char *subcmd = NULL;
+
+ if (objects) {
+ objv = (Tcl_Obj **)vector;
+ subcmd = Tcl_GetStringFromObj(objv[1], NULL);
+ if (strcmp(subcmd, "help") == 0) {
+ Tcl_SetResult(interp, "no help available", TCL_STATIC);
+ return TCL_OK;
+ }
+ }
+
+ return TCL_CONTINUE;
+ }
^L
/*
*----------------------------------------------------------------------
***************
*** 663,668 ****
--- 734,740 ----
char copyBuf[STATIC_SIZE], *fmtCopy;
register char *dst;

+ Tcl_CreateSubCmdHandler(interp, "info", (Tcl_SubCmdHandler
*)Tcl_TestHandlerProc2, NULL);
if (argc < 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" string format ?varName varName ...?\"", (char *) NULL);
***************
*** 1770,1775 ****
--- 1842,1849 ----
*/

/* ARGSUSED */
+
+
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
***************
*** 1783,1788 ****
--- 1857,1864 ----
double totalMicroSec;
Tcl_Time start, stop;
char buf[100];
+
+ Tcl_CreateSubCmdHandler(interp, "info", (Tcl_SubCmdHandler
*)Tcl_TestHandlerProc, NULL);

if (objc == 2) {
count = 1;
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/generic/tclDecls.h,v
retrieving revision 1.6
diff -c -r1.6 tclDecls.h
*** tclDecls.h 1999/03/11 02:49:34 1.6
--- tclDecls.h 1999/05/06 16:13:49
***************
*** 872,877 ****
--- 872,888 ----
/* 279 */
EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor,
int * patchLevel, int * type));
+ /* Slot 280 is reserved */
+ /* Slot 281 is reserved */
+ /* Slot 282 is reserved */
+ /* Slot 283 is reserved */
+ /* Slot 284 is reserved */
+ /* Slot 285 is reserved */
+ /* 286 */
+ EXTERN void Tcl_CreateSubCmdHandler _ANSI_ARGS_((
+ Tcl_Interp * interp, char * cmdname,
+ Tcl_SubCmdHandler * proc,
+ ClientData clientData));

typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
***************
*** 1187,1192 ****
--- 1198,1210 ----
Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int
options)); /* 277 */
void (*panicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */
void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int *
patchLevel, int * type)); /* 279 */
+ void *reserved280;
+ void *reserved281;
+ void *reserved282;
+ void *reserved283;
+ void *reserved284;
+ void *reserved285;
+ void (*tcl_CreateSubCmdHandler) _ANSI_ARGS_((Tcl_Interp * interp, char *
cmdname, Tcl_SubCmdHandler * proc, ClientData clientData)); /* 286 */
} TclStubs;

extern TclStubs *tclStubsPtr; *************** *** 2319,2324 **** ---
2337,2352 ---- #ifndef Tcl_GetVersion #define Tcl_GetVersion(major, minor,
patchLevel, type) \ (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel,
type) /* 279 */ + #endif + /* Slot 280 is reserved */ + /* Slot 281 is
reserved */ + /* Slot 282 is reserved */ + /* Slot 283 is reserved */ + /*
Slot 284 is reserved */ + /* Slot 285 is reserved */ + #ifndef
Tcl_CreateSubCmdHandler + #define Tcl_CreateSubCmdHandler(interp, cmdname,
proc, clientData) \ + (tclStubsPtr->tcl_CreateSubCmdHandler)(interp,
cmdname, proc, clientData) /* 286 */ #endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/generic/tclInt.h,v
retrieving revision 1.24
diff -c -r1.24 tclInt.h
*** tclInt.h 1999/03/10 05:52:48 1.24
--- tclInt.h 1999/05/06 16:14:00
***************
*** 764,769 ****
--- 764,777 ----
} MathFunc;

/* + * The data structure that stores information about a subcommand
handler. + */ + typedef struct SubCmdProc { + Tcl_SubCmdHandler *proc; +
struct SubCmdProc *next; + } SubCmdProc; + + /*
*---------------------------------------------------------------- * Data
structures related to bytecode compilation and execution. * These are used
primarily in tclCompile.c, tclExecute.c, and *************** *** 1054,1059
**** --- 1062,1071 ---- * defined for the interpreter. Indexed by *
strings (function names); values have * type (MathFunc *). */ +
Tcl_HashTable subCmdTable; /* Contains all the commands currently + *
registered as having enhanced subcommands. + * Indexed by strings (command
names); + * values have type (SubCmd *). */

/*
* Information related to procedures and variables. See tclProc.c
***************
*** 1521,1526 ****
--- 1533,1539 ----
EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void));
EXTERN void TclInitNamespaces _ANSI_ARGS_((void));
EXTERN void TclpFinalize _ANSI_ARGS_((void));
+ EXTERN Tcl_HashTable *Tcl_GetSubCmdTable _ANSI_ARGS_((Tcl_Interp *interp));

/* *----------------------------------------------------------------
Index: generic/tclInterp.c
=================================================================== RCS file:
/cvsroot/tcl/generic/tclInterp.c,v retrieving revision 1.4 diff -c -r1.4
tclInterp.c *** tclInterp.c 1999/02/03 02:58:40 1.4 --- tclInterp.c
1999/05/06 16:14:03 *************** *** 737,748 **** Slave *slavePtr; /*
Interim storage for slave record. */ Tcl_Interp *masterInterp; /* Master of
interp. to delete. */ Tcl_HashEntry *hPtr; /* Search element. */ int
localArgc; /* Local copy of count of elements in * path (name) of interp.
to delete. */ char **localArgv; /* Local copy of path. */ char *slaveName;
/* Last component in path. */ char *masterPath; /* One-before-last
component in path.*/ ! if (Tcl_SplitList(interp, path, &localArgc,
&localArgv) != TCL_OK) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad interpreter path \"", path, "\"", (char *) NULL); --- 737,750 ----
Slave *slavePtr; /* Interim storage for slave record. */ Tcl_Interp
*masterInterp; /* Master of interp. to delete. */ Tcl_HashEntry *hPtr; /*
Search element. */ + Tcl_HashSearch hSrch; int localArgc; /* Local copy of
count of elements in * path (name) of interp. to delete. */ char
**localArgv; /* Local copy of path. */ char *slaveName; /* Last component
in path. */ char *masterPath; /* One-before-last component in path.*/ !
SubCmdProc *subCmdProc, *loopPtr; ! if (Tcl_SplitList(interp, path,
&localArgc, &localArgv) != TCL_OK) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad interpreter path \"",
path, "\"", (char *) NULL); *************** *** 785,790 **** --- 787,804 ----
} ckfree((char *) localArgv);

+ while (hPtr = Tcl_FirstHashEntry(&((Interp
*)slavePtr->slaveInterp)->subCmdTable, &hSrch)){
+ subCmdProc = (SubCmdProc *)Tcl_GetHashValue(hPtr);
+ while (subCmdProc) {
+ subCmdProc->proc (NULL, NULL, 0, 0, NULL);
+ loopPtr = subCmdProc->next;
+ ckfree((char *)subCmdProc);
+ subCmdProc = loopPtr;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&((Interp *)slavePtr->slaveInterp)->subCmdTable);
+
return TCL_OK;
}
^L
***************
*** 3810,3813 ****
--- 3824,3867 ----
*objvPtr = aliasPtr->objv;
}
return TCL_OK;
+ }
+
+ void
+ Tcl_CreateSubCmdHandler(interp, cmdname, proc, clientData)
+ Tcl_Interp *interp;
+ char *cmdname;
+ Tcl_SubCmdHandler *proc;
+ ClientData clientData;
+ {
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ SubCmdProc *newPtr, *entryPtr, *loopPtr;
+ int new;
+
+ newPtr = (SubCmdProc *)ckalloc(sizeof(SubCmdProc));
+ newPtr->proc = proc;
+ newPtr->next = NULL;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->subCmdTable, cmdname, &new);
+ if (new) {
+ Tcl_SetHashValue(hPtr, newPtr);
+ }
+ entryPtr = (SubCmdProc *) Tcl_GetHashValue(hPtr);
+
+ if (!new) {
+ for (loopPtr = entryPtr; loopPtr->next; loopPtr = loopPtr->next) {
+ if (loopPtr->proc == proc) break;
+ }
+ if (loopPtr->proc != proc) {
+ loopPtr->next = newPtr;
+ }
+ }
+ }
+
+ Tcl_HashTable *
+ Tcl_GetSubCmdTable(interp)
+ Tcl_Interp *interp;
+ {
+ Interp *iPtr = (Interp *) interp;
+ return &iPtr->subCmdTable;
}
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/generic/tclStubInit.c,v
retrieving revision 1.6
diff -c -r1.6 tclStubInit.c
*** tclStubInit.c 1999/03/11 00:19:23 1.6
--- tclStubInit.c 1999/05/06 16:14:12
***************
*** 350,355 ****
--- 350,362 ----
Tcl_WaitPid, /* 277 */
panicVA, /* 278 */
Tcl_GetVersion, /* 279 */
+ NULL, /* 280 */
+ NULL, /* 281 */
+ NULL, /* 282 */
+ NULL, /* 283 */
+ NULL, /* 284 */
+ NULL, /* 285 */
+ Tcl_CreateSubCmdHandler, /* 286 */
};

TclStubs *tclStubsPtr = &tclStubs;
Index: generic/tclStubs.c
===================================================================
RCS file: /cvsroot/tcl/generic/tclStubs.c,v
retrieving revision 1.6
diff -c -r1.6 tclStubs.c
*** tclStubs.c 1999/03/11 02:49:34 1.6
--- tclStubs.c 1999/05/06 16:14:13
***************
*** 2706,2710 ****
--- 2706,2727 ----
(tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type);
}

+ /* Slot 280 is reserved */ + /* Slot 281 is reserved */ + /* Slot 282 is
reserved */ + /* Slot 283 is reserved */ + /* Slot 284 is reserved */ + /*
Slot 285 is reserved */ + /* Slot 286 */ + void +
Tcl_CreateSubCmdHandler(interp, cmdname, proc, clientData) + Tcl_Interp *
interp; + char * cmdname; + Tcl_SubCmdHandler * proc; + ClientData
clientData; + { + (tclStubsPtr->tcl_CreateSubCmdHandler)(interp, cmdname,
proc, clientData); + } +

/* !END!: Do not edit above this line. */

Bruce S. O. Adams

unread,
May 6, 1999, 3:00:00 AM5/6/99
to Marco R. Gazzetta

"Marco R. Gazzetta" wrote:

[patch snipped]

I haven't yet started on my own trail of destruction (kernal hacking :-). However,
I
am writing an introspection package (essentially an info extension) and would love
to know exactly what kind of augmentation you mean (so I can include it). I will
certainly look at your patch as I was planning something like this for the C
version.
In the TCL only version I have a subcommand facility based on just switching on the
first argument (though it could be extended to allow a tertiary level or generic if
anyone
actually desires such a feature). See related posting on this thread.
Regards,
Bruce A.

P.S. Is there anything Itcl adds to the info command that would I should look at
including?
I have not examined the OO extensions much (other than stooop at work). I posted
the
original spec a while back and a copy should still be floating around on the
Tcler's wiki
(url not to hand).


Alexandre Ferrieux

unread,
May 7, 1999, 3:00:00 AM5/7/99
to
Marco R. Gazzetta wrote:
>
> I couldn't resist the temptation and I'm attaching a patch file
>

Wow !!! Thanks !!!

It's really a pleasure to be acquainted with smart and efficient people.

Now I am really sorry but I'm leaving for a week within hours; I'm not
sure I can find the time to try it until next week... Shame on me !

Talk to you then,

Best regards,

-Alex

Reply all
Reply to author
Forward
0 new messages