Itcl - the [incr Tcl] extension

 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *  overhauled version author: Arnulf Wiedemann
 *
 *     RCS:  $Id: itclCmd.c,v 1.1.2.51 2009/10/18 16:38:07 wiede Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

    handledActiveNs = 0;
    while (Itcl_GetStackSize(&search) > 0) {
        nsPtr = Itcl_PopStack(&search);
        if (nsPtr == activeNs && handledActiveNs) {
            continue;
        }

        hPtr = Tcl_FirstHashEntry(Tcl_GetNamespaceCommandTable(nsPtr),
	        &place);
        while (hPtr) {
            cmd = (Tcl_Command)Tcl_GetHashValue(hPtr);
            if (Itcl_IsClass(cmd)) {
                originalCmd = Tcl_GetOriginalCommand(cmd);

                /*

        }
        handledActiveNs = 1;  /* don't process the active namespace twice */

        /*
         *  Push any child namespaces onto the stack and continue
         *  the search in those namespaces.
         */
        hPtr = Tcl_FirstHashEntry(Tcl_GetNamespaceChildTable(nsPtr), &place);
        while (hPtr != NULL) {
            Itcl_PushStack(Tcl_GetHashValue(hPtr), &search);
            hPtr = Tcl_NextHashEntry(&place);
        }
    }
    Tcl_DeleteHashTable(&unique);
    Itcl_DeleteStack(&search);

    handledActiveNs = 0;
    while (Itcl_GetStackSize(&search) > 0) {
        nsPtr = Itcl_PopStack(&search);
        if (nsPtr == activeNs && handledActiveNs) {
            continue;
        }

        entry = Tcl_FirstHashEntry(Tcl_GetNamespaceCommandTable(nsPtr), &place);
        while (entry) {
            cmd = (Tcl_Command)Tcl_GetHashValue(entry);
            if (Itcl_IsObject(cmd)) {
                originalCmd = Tcl_GetOriginalCommand(cmd);
                if (originalCmd) {
                    cmd = originalCmd;
                }

        }
        handledActiveNs = 1;  /* don't process the active namespace twice */

        /*
         *  Push any child namespaces onto the stack and continue
         *  the search in those namespaces.
         */
        entry = Tcl_FirstHashEntry(Tcl_GetNamespaceChildTable(nsPtr), &place);
        while (entry != NULL) {
            Itcl_PushStack(Tcl_GetHashValue(entry), &search);
            entry = Tcl_NextHashEntry(&place);
        }
    }
    Tcl_DeleteHashTable(&unique);
    Itcl_DeleteStack(&search);

/*
 * itclHelpers.c --
 *
 * This file contains the C-implemeted part of 
 * Itcl 
 *
 * Copyright (c) 2007 by Arnulf P. Wiedemann
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: itclHelpers.c,v 1.1.2.15 2009/10/18 16:42:33 wiede Exp $
 */

#include "itclInt.h"

void ItclDeleteArgList(ItclArgList *arglistPtr);
#ifdef ITCL_DEBUG
int _itcl_debug_level = 0;

{
    int result;
    Tcl_Obj **newObjv;
    int isRootEnsemble;
    ItclShowArgs(2, functionName, objc, objv);

    newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1));
    isRootEnsemble = Tcl_InitRewriteEnsemble(interp, 1, 2, objc, objv);
    newObjv[0] = Tcl_NewStringObj("::info", -1);
    Tcl_IncrRefCount(newObjv[0]);
    newObjv[1] = Tcl_NewStringObj("itclinfo", -1);
    Tcl_IncrRefCount(newObjv[1]);
    if (objc > 1) {
        memcpy(newObjv+2, objv+1, sizeof(Tcl_Obj *) * (objc-1));
    }
    result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_INVOKE);
    Tcl_DecrRefCount(newObjv[0]);
    Tcl_DecrRefCount(newObjv[1]);
    ckfree((char *)newObjv);
    Tcl_ResetRewriteEnsemble(interp, isRootEnsemble);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  ItclTraceUnsetVar()

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  This file contains procedures that belong in the Tcl/Tk core.
 *  Hopefully, they'll migrate there soon.
 *
 * ========================================================================
 *  AUTHOR:  Arnulf Wiedemann
 *
 *     RCS:  $Id: itclMigrate2TclCore.c,v 1.1.2.10 2009/01/14 22:43:24 davygrvy Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include <tcl.h>

	framePtr->resolvePtr = resolvePtr;
#endif
        return TCL_OK;
    }
    return TCL_ERROR;
}

Tcl_HashTable *
_Tcl_GetNamespaceCommandTable(
    Tcl_Namespace *nsPtr)
{
    return &((Namespace *)nsPtr)->cmdTable;
}

Tcl_HashTable *
_Tcl_GetNamespaceChildTable(
    Tcl_Namespace *nsPtr)
{
    return &((Namespace *)nsPtr)->childTable;
}

int
_Tcl_InitRewriteEnsemble(
    Tcl_Interp *interp,
    int numRemoved,
    int numInserted,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;

    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);

    if (isRootEnsemble) {
        iPtr->ensembleRewrite.sourceObjs = objv;
        iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
        iPtr->ensembleRewrite.numInsertedObjs = numInserted;
    } else {
        int numIns = iPtr->ensembleRewrite.numInsertedObjs;
        if (numIns < numRemoved) {
            iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
            iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
        } else {
            iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
        }
    }
    return isRootEnsemble;
}

void
_Tcl_ResetRewriteEnsemble(
    Tcl_Interp *interp,
    int isRootEnsemble)
{
    Interp *iPtr = (Interp *) interp;

    if (isRootEnsemble) {
        iPtr->ensembleRewrite.sourceObjs = NULL;
        iPtr->ensembleRewrite.numRemovedObjs = 0;
        iPtr->ensembleRewrite.numInsertedObjs = 0;
    }
}

int
_Tcl_SetNamespaceResolver(
    Tcl_Namespace *nsPtr,
    Tcl_Resolve *resolvePtr)
{
    if (nsPtr == NULL) {
        return TCL_ERROR;

#ifndef _TCL_PROC_DEFINED
typedef struct Tcl_Proc_ *Tcl_Proc;
#define _TCL_PROC_DEFINED 1
#endif

typedef void (*Tcl_ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);

#define Tcl_GetNamespaceCommandTable _Tcl_GetNamespaceCommandTable
#define Tcl_GetNamespaceChildTable _Tcl_GetNamespaceChildTable
#define Tcl_InitRewriteEnsemble _Tcl_InitRewriteEnsemble
#define Tcl_ResetRewriteEnsemble _Tcl_ResetRewriteEnsemble
#define Tcl_SetProcCmd _Tcl_SetProcCmd
#define Tcl_InvokeNamespaceProc _Tcl_InvokeNamespaceProc


extern Tcl_HashTable *_Tcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr);

extern Tcl_HashTable *_Tcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr);
extern int _Tcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
	int numInserted, int objc, Tcl_Obj *const *objv);
extern void _Tcl_ResetRewriteEnsemble(Tcl_Interp *interp,
        int isRootEnsemble);
extern int _Tcl_InvokeNamespaceProc(Tcl_Interp *interp, Tcl_Proc proc,
        Tcl_Namespace *nsPtr, Tcl_Obj *namePtr, int objc, Tcl_Obj *const *objv);
extern Tcl_Var Tcl_NewNamespaceVar(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
	const char *varName);
extern int Itcl_IsCallFrameArgument(Tcl_Interp *interp, const char *name);

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  This file contains procedures that use the internal Tcl core stubs
 *  entries.
 *
 * ========================================================================
 *  AUTHOR:  Arnulf Wiedemann
 *
 *     RCS:  $Id: itclTclIntStubsFcn.c,v 1.1.2.3 2009/10/18 16:46:23 wiede Exp $
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include <tcl.h>
#include <tclInt.h>
#include "itclInt.h"

    Tcl_Namespace * namespacePtr,
    Tcl_ResolveCmdProc * cmdProc,
    Tcl_ResolveVarProc * varProc,
    Tcl_ResolveCompiledVarProc * compiledVarProc)
{
    Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc);
}

        Tcl_Proc *procPtrPtr);
extern void _Tcl_ProcDeleteProc(ClientData clientData);
extern void *_Tcl_GetObjInterpProc(void);
extern int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr,
        struct Tcl_Resolve *resolvePtr);
extern int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName,
	const char *newName);