matrix: ${{ fromJson(needs.plan.outputs.gcc) }}
    defaults:
      run:
        shell: bash
        working-directory: unix
    steps:
      - name: Checkout
        uses: actions/checkout@v5
        timeout-minutes: 5
      - name: Install 32-bit dependencies if needed
        # Duplicated from above
        if: ${{ matrix.config == 'CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit' }}
        run: |
          sudo apt-get update
          sudo apt-get install gcc-multilib libc6-dev-i386

    runs-on: macos-15
    defaults:
      run:
        shell: bash
        working-directory: macosx
    steps:
      - name: Checkout
        uses: actions/checkout@v5
        timeout-minutes: 5
      - name: Prepare
        run: |
          touch tclStubInit.c tclOOStubInit.c tclOOScript.h
        working-directory: generic
      - name: Build
        run: make -j4 all

      matrix: ${{ fromJson(needs.plan.outputs.clang) }}
    defaults:
      run:
        shell: bash
        working-directory: unix
    steps:
      - name: Checkout
        uses: actions/checkout@v5
        timeout-minutes: 5
      - name: Prepare
        run: |
          touch tclStubInit.c tclOOStubInit.c tclOOScript.h
          mkdir "$HOME/install dir"
        working-directory: generic
      - name: Configure ${{ matrix.config }}

    runs-on: ubuntu-24.04
    defaults:
      run:
        shell: bash
    timeout-minutes: 10
    steps:
      - name: Checkout
        uses: actions/checkout@v5
      - name: Prepare
        run: |
          touch generic/tclStubInit.c generic/tclOOStubInit.c
          mkdir 1dist
          echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
        working-directory: .
      - name: Configure

    runs-on: macos-13
    defaults:
      run:
        shell: bash
    timeout-minutes: 10
    steps:
      - name: Checkout
        uses: actions/checkout@v5
      - name: Checkout create-dmg
        uses: actions/checkout@v5
        with:
          repository: create-dmg/create-dmg
          ref: v1.0.8
          path: create-dmg
      - name: Prepare
        run: |
          mkdir 1dist

    steps:
      - name: Install MSYS2
        uses: msys2/setup-msys2@v2
        with:
          msystem: UCRT64
          install: git mingw-w64-ucrt-x86_64-toolchain make zip
      - name: Checkout
        uses: actions/checkout@v5
      - name: Prepare
        run: |
          touch generic/tclStubInit.c generic/tclOOStubInit.c
          echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
          mkdir 1dist
        working-directory: .
      - name: Configure

      # https://docs.github.com/en/actions/writing-workflows/choosing-what-your-workflow-does/store-information-in-variables
      REMOTE_PATH: ${{ vars.PUBLISH_DROP_PATH }}/data-${{ github.sha }}
    steps:
      - name: Make directory
        run: |
          mkdir data
      - name: Get Linux build
        uses: actions/download-artifact@v5
        with:
          path: data
          # Can't download by artifact ID; stupid missing feature!
          merge-multiple: true
      - name: Check data downloaded
        run: |
          ls -AlR

        shell: powershell
        working-directory: win
    strategy:
      matrix: ${{ fromJson(needs.plan.outputs.msvc) }}
    # Using powershell means we need to explicitly stop on failure
    steps:
      - name: Checkout
        uses: actions/checkout@v5
        timeout-minutes: 5
      - name: Init MSVC
        uses: ilammy/msvc-dev-cmd@v1
        timeout-minutes: 5
      - name: Build ${{ matrix.config }}
        run: |
          &nmake -f makefile.vc ${{ matrix.config }} all

      - name: Install MSYS2
        uses: msys2/setup-msys2@v2
        with:
          msystem: MINGW64
          install: git mingw-w64-x86_64-toolchain make
        timeout-minutes: 10
      - name: Checkout
        uses: actions/checkout@v5
        timeout-minutes: 5
      - name: Prepare
        run: |
          touch tclStubInit.c tclOOStubInit.c tclOOScript.h
          mkdir "${HOME}/install dir"
        working-directory: generic
      - name: Configure ${{ matrix.config }}

# README:  Tcl

This is the **Tcl 9.1a1** source distribution.

You can get any source release of Tcl from [our distribution
site](https://sourceforge.net/projects/tcl/files/Tcl/).

9.1 (in development, daily build)
[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Amain)
[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Amain)

The source code for Tcl is managed by fossil.  Tcl developers coordinate all
changes to the Tcl source code at

> [Tcl Source Code](https://core.tcl-lang.org/tcl/timeline)

Release Tcl 9.1a1 arises from the check-in with tag `core-9-1-a1`.

Highlighted differences between Tcl 9.1 and Tcl 9.0 are summarized below,
with focus on changes important to programmers using the Tcl library and
writing Tcl scripts.

# New commands and options

- [New options -backslashes, -commands and -variables for subst command](https://core.tcl-lang.org/tips/doc/trunk/tip/712.md)

# New public C API

- [Tcl\_IsEmpty checks if the string representation of a value would be the empty string](https://core.tcl-lang.org/tips/doc/trunk/tip/711.md)
- [Tcl\_GetEncodingNameForUser returns name of encoding from user settings](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md)
- [Tcl\_AttemptCreateHashEntry - version of Tcl\_CreateHashEntry that returns NULL instead of panic'ing on memory allocation errors](https://core.tcl-lang.org/tips/doc/trunk/tip/717.md)
- [Tcl\_ListObjRange, Tcl\_ListObjRepeat, Tcl\_TclListObjReverse - C API for new list operations](https://core.tcl-lang.org/tips/doc/trunk/tip/649.md)

# Performance

- [Memory efficient internal representations](https://core.tcl-lang.org/tcl/wiki?name=New+abstract+list+representations)
for list operations on large lists.

# Bug fixes

#   define TCL_MAJOR_VERSION	9
#endif
#if TCL_MAJOR_VERSION != 9
#   error "This header-file is for Tcl 9 only"
#endif
#define TCL_MINOR_VERSION   1
#define TCL_RELEASE_LEVEL   TCL_ALPHA_RELEASE
#define TCL_RELEASE_SERIAL  1

#define TCL_VERSION	    "9.1"
#define TCL_PATCH_LEVEL	    "9.1a1"

#if defined(RC_INVOKED)
/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

	    size_t lastTZEpoch = TzsetIfNecessary();

	    if (i < objc) {
		if (dataPtr->systemTimeZone != objv[i]) {
		    TclSetObjRef(dataPtr->systemTimeZone, objv[i]);
		    TclUnsetObjRef(dataPtr->systemSetupTZData);
		}
		if (dataPtr->lastTZEpoch != lastTZEpoch) {
		    dataPtr->lastTZEpoch = lastTZEpoch;
		    /* TZ epoch changed - invalidate base-cache */
		    TclUnsetObjRef(dataPtr->lastBase.timezoneObj);
		}
	    }
	    if (i + 1 >= objc && dataPtr->systemTimeZone != NULL
		    && dataPtr->lastTZEpoch == lastTZEpoch) {
		Tcl_SetObjResult(interp, dataPtr->systemTimeZone);
	    }
	    break;
	}

    /*
     * Push all remaining words; there's definitely at least two.
     */

    Tcl_Token *tokenPtr = TokenAfter(varTokenPtr);
    for (i=2; i<numWords; i++, tokenPtr=TokenAfter(tokenPtr)) {
	PUSH_TOKEN(		tokenPtr, i);
    }

    // Stack: varWords... idx1 idx2 values...
    //        {len=[0-2]} { len=numWords-2  }

    /*
     * Read the variable. This requires us to copy the varWords first (if there

    }

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    TclNewObj(objPtr);
    if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
	/*
	 * If the first argument isn't known at compile time, we can't know if
	 * it is a script fragment or a level descriptor. Punt.
	 */
	Tcl_DecrRefCount(objPtr);
	return TCL_ERROR;
    }

    /*
     * Attempt to convert to a level reference. Note that TclObjGetFrame

 * Results:
 *	The return value is TCL_OK if the system encoding was successfully set
 *	to the encoding specified by name, TCL_ERROR otherwise. If TCL_ERROR
 *	is returned, an error message is left in interp's result object,
 *	unless interp was NULL.
 *
 * Side effects:
 *	If the passed encoding is the same as the current system
 *	encoding, the call is effectively a no-op. Otherwise, the reference
 *	count of the new system encoding is incremented. The reference count
 *	of the old system encoding is decremented and it may be freed. All
 *	VFS cached information is invalidated.
 *
 *------------------------------------------------------------------------
 */

int
Tcl_SetSystemEncoding(
    Tcl_Interp *interp,		/* Interp for error reporting, if not NULL. */
    const char *name)		/* The name of the desired encoding, or NULL/""
				 * to reset to default encoding. */
{
    Tcl_Encoding encoding;



    Tcl_MutexLock(&encodingMutex);
    if (name == NULL || name[0] == '\0') {
	if (defaultEncoding == systemEncoding) {


	    Tcl_MutexUnlock(&encodingMutex);
	    return TCL_OK;
	}
	encoding = defaultEncoding;
	((Encoding *)encoding)->refCount += 1;
    } else {
	encoding = Tcl_GetEncoding(interp, name);
	if (encoding == NULL) {
	    Tcl_MutexUnlock(&encodingMutex);
	    return TCL_ERROR;
	}
	if (encoding == systemEncoding) {
	    FreeEncoding(encoding);
	    Tcl_MutexUnlock(&encodingMutex);
	    return TCL_OK;
	}
    }

    assert(encoding != systemEncoding);
    FreeEncoding(systemEncoding);
    systemEncoding = encoding;
    Tcl_MutexUnlock(&encodingMutex);

    /* Checks above ensure this is only called when system encoding changes */
    Tcl_FSMountsChanged(NULL);

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------

	 */

    case INST_JUMP_TABLE_NUM:
	tblIdx = TclGetInt4AtPtr(pc + 1);
	JumptableNumInfo *jtnPtr = (JumptableNumInfo *)
		codePtr->auxDataArrayPtr[tblIdx].clientData;
	TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS)));
	DECACHE_STACK_INFO();
	Tcl_WideInt key;
	if (Tcl_GetWideIntFromObj(interp, OBJ_AT_TOS, &key) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	CACHE_STACK_INFO();
	hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, INT2PTR(key));

    processJumpTableEntry:
	if (hPtr != NULL) {
	    Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));

	    TRACE_APPEND(("found in table, new pc %" SIZEu "\n",
		    PC_REL + jumpOffset));
	    NEXT_INST_F0(jumpOffset, 1);
	}

	TRACE_APPEND(("not found in table\n"));
	NEXT_INST_F0(5, 1);
    }

    /*
     * -----------------------------------------------------------------
     *	   Start of general introspector instructions.

			    int objc, Tcl_Obj *const objv[], int copyFlag);
static int		FileForceOption(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[], int *forcePtr);

/*
 *---------------------------------------------------------------------------
 *
 * CheckFilenameEncodable
 *
 *	This checks if a filename can be encoded on the target platform,
 *	disallowing things like naked surrogates, etc.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May update the interpreter result with an error message on failure.
 *
 *---------------------------------------------------------------------------
 */
static inline int
CheckFilenameEncodable(
    Tcl_Interp *interp,
    Tcl_Obj *fileName)
{
    Tcl_DString ds;
    int code = Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING,
	    TclGetString(fileName), TCL_INDEX_NONE, 0, &ds, NULL);
    Tcl_DStringFree(&ds);
    return code == TCL_OK ? TCL_OK : TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileRenameCmd
 *
 *	This function implements the "rename" subcommand of the "file"
 *	command. Filename arguments need to be translated to native format
 *	before being passed to platform-specific code that implements rename
 *	functionality.
 *

    Tcl_Obj *const objv[],	/* Argument strings passed to Tcl_FileCmd. */
    int copyFlag)		/* If non-zero, copy source(s). Otherwise,
				 * rename them. */
{
    int i, result, force;
    Tcl_StatBuf statBuf;
    Tcl_Obj *target;


    i = FileForceOption(interp, objc - 1, objv + 1, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i++;
    if ((objc - i) < 2) {

     * than 2 arguments is only valid if the target is an existing directory.
     */

    target = objv[objc - 1];
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    if (CheckFilenameEncodable(interp, target) != TCL_OK) {

	return TCL_ERROR;
    }


    result = TCL_OK;

    /*
     * Call Tcl_FSStat() so that if target is a symlink that points to a
     * directory we will put the sources in that directory instead of
     * overwriting the symlink.

{
    Tcl_Obj *errfile = NULL;
    int result, i;
    Tcl_Size j, pobjc;
    Tcl_Obj *split = NULL;
    Tcl_Obj *target = NULL;
    Tcl_StatBuf statBuf;


    result = TCL_OK;
    for (i = 1; i < objc; i++) {
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    break;
	}

	if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) {

	    result = TCL_ERROR;
	    break;
	}


	split = Tcl_FSSplitPath(objv[i], &pobjc);
	Tcl_IncrRefCount(split);
	if (pobjc == 0) {
	    errno = ENOENT;
	    errfile = objv[i];
	    break;

    Tcl_Interp *interp,		/* Used for error reporting */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    int i, force, result;
    Tcl_Obj *errfile;
    Tcl_Obj *errorBuffer = NULL;


    i = FileForceOption(interp, objc - 1, objv + 1, &force);
    if (i < 0) {
	return TCL_ERROR;
    }

    errfile = NULL;
    result = TCL_OK;

    for (i++ ; i < objc; i++) {
	Tcl_StatBuf statBuf;

	errfile = objv[i];
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    goto done;
	}

	if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) {

	    result = TCL_ERROR;
	    goto done;
	}


	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    result = TCL_ERROR;

				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    Tcl_Obj *actualSource=NULL;	/* If source is a link, then this is the real
				 * file/directory. */
    Tcl_StatBuf sourceStatBuf, targetStatBuf;


    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }

    if (CheckFilenameEncodable(interp, source) != TCL_OK) {

	return TCL_ERROR;
    }

    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    if (CheckFilenameEncodable(interp, target) != TCL_OK) {

	return TCL_ERROR;
    }


    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;

    /*
     * We want to copy/rename links and not the files they point to, so we use

{
    int result;
    const char *const *attributeStrings;
    const char **attributeStringsAllocated = NULL;
    Tcl_Obj *objStrings = NULL;
    Tcl_Size numObjStrings = TCL_INDEX_NONE;
    Tcl_Obj *filePtr;


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
	return TCL_ERROR;
    }

    filePtr = objv[1];
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (CheckFilenameEncodable(interp, filePtr) != TCL_OK) {

	return TCL_ERROR;
    }


    objc -= 2;
    objv += 2;
    result = TCL_ERROR;
    Tcl_SetErrno(0);

    /*

    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *contents;
    int index;


    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?");
	return TCL_ERROR;
    }

    /*

	    }
	} else {
	    linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK;
	}
	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
	    return TCL_ERROR;
	}

	if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) {

	    return TCL_ERROR;
	}


	/*
	 * Create link from source to target.
	 */

	contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
	if (contents == NULL) {

	    }
	    return TCL_ERROR;
	}
    } else {
	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
	    return TCL_ERROR;
	}

	if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) {

	    return TCL_ERROR;
	}


	/*
	 * Read link
	 */

	contents = Tcl_FSLink(objv[index], NULL, 0);
	if (contents == NULL) {

TclFileReadLinkCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *contents;


    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name");
	return TCL_ERROR;
    }

    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
	return TCL_ERROR;
    }

    if (CheckFilenameEncodable(interp, objv[1]) != TCL_OK) {

	return TCL_ERROR;
    }


    contents = Tcl_FSLink(objv[1], NULL, 0);

    if (contents == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"could not read link \"%s\": %s",
		TclGetString(objv[1]), Tcl_PosixError(interp)));

	return TCL_ERROR;
    }

#ifndef _WIN32
    /*
     * It might be necessary on some systems to set the appropriate permissions
     * on the file.  On Unix we could loop over the file attributes and set any
     * that are called "-permissions" to 0o700, but just do it directly instead:
     */

    {
	Tcl_Size index;
	Tcl_Obj *perm;

	TclNewLiteralStringObj(perm, "0o700");
	Tcl_IncrRefCount(perm);
	if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) {
	    Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);
	}
	Tcl_DecrRefCount(perm);
    }
#endif

 *----------------------------------------------------------------
 */

MODULE_SCOPE void	TclAdvanceContinuations(int *line, Tcl_Size **next,
			    Tcl_Size loc);
MODULE_SCOPE void	TclAdvanceLines(int *line, const char *start,
			    const char *end);
MODULE_SCOPE int	TclAliasCreate(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
			    const unsigned char *bytes, Tcl_Size len);
MODULE_SCOPE void	TclAppendUtfToUtf(Tcl_Obj *objPtr,
			    const char *bytes, Tcl_Size numBytes);
MODULE_SCOPE void	TclArgumentEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], Tcl_Size objc, CmdFrame *cf);
MODULE_SCOPE void	TclArgumentRelease(Tcl_Interp *interp,

MODULE_SCOPE void *	TclpThreadGetGlobalTSD(void *tsdKeyPtr);
MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp,
			    const char *msg, Tcl_Size length);
/* Tip 430 */
MODULE_SCOPE int	TclZipfs_Init(Tcl_Interp *interp);
MODULE_SCOPE int	TclIsZipfsPath(const char *path);
MODULE_SCOPE void	TclZipfsFinalize(void);
MODULE_SCOPE int	TclZipfsLocateTclLibrary(void);

/*
 * Many parsing tasks need a common definition of whitespace.
 * Use this routine and macro to achieve that and place
 * optimization (fragile on changes) in one place.
 */

#define INTERP_INFO(interp) \
	((InterpInfo *) ((Interp *) (interp))->interpInfo)

/*
 * Prototypes for local static functions:
 */





static int		AliasDelete(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Obj *namePtr);
static int		AliasDescribe(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Obj *objPtr);
static int		AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp);
static Tcl_ObjCmdProc	AliasNRCmd;
static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;

	}
	if (objc > 5) {
	    parentInterp = GetInterp(interp, objv[4]);
	    if (parentInterp == NULL) {
		return TCL_ERROR;
	    }

	    return TclAliasCreate(interp, childInterp, parentInterp, objv[3],
		    objv[5], objc - 6, objv + 6);
	}

    aliasArgs:
	Tcl_WrongNumArgs(interp, 2, objv,
		"childPath childCmd ?parentPath parentCmd? ?arg ...?");
	return TCL_ERROR;

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    TclStackFree(childInterp, objv);
    Tcl_DecrRefCount(targetObjPtr);

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, objc, objv);

    Tcl_DecrRefCount(childObjPtr);
    Tcl_DecrRefCount(targetObjPtr);
    return result;
}


	nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAliasCreate --
 *
 *	Helper function to do the work to actually create an alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	An alias command is created and entered into the alias table for the
 *	child interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclAliasCreate(
    Tcl_Interp *interp,		/* Interp for error reporting. */
    Tcl_Interp *childInterp,	/* Interp where alias cmd will live or from
				 * which alias will be deleted. */
    Tcl_Interp *parentInterp,	/* Interp in which target command will be
				 * invoked. */
    Tcl_Obj *namePtr,		/* Name of alias cmd. */
    Tcl_Obj *targetCmdPtr,	/* Name of target cmd. */

    if (safe) {
	Tcl_Obj *clockObj;
	int status;

	TclNewLiteralStringObj(clockObj, "clock");
	Tcl_IncrRefCount(clockObj);
	status = TclAliasCreate(interp, childInterp, parentInterp, clockObj,
		clockObj, 0, NULL);
	Tcl_DecrRefCount(clockObj);
	if (status != TCL_OK) {
	    goto error2;
	}
    }

		return AliasDescribe(interp, childInterp, objv[2]);
	    }
	    if (TclGetString(objv[3])[0] == '\0') {
		if (objc == 4) {
		    return AliasDelete(interp, childInterp, objv[2]);
		}
	    } else {
		return TclAliasCreate(interp, childInterp, interp, objv[2],
			objv[3], objc - 4, objv + 4);
	    }
	}
	Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
	return TCL_ERROR;
    case OPT_ALIASES:
	if (objc != 2) {

 *
 *----------------------------------------------------------------------
 */

void
Tcl_QueueEvent(
    Tcl_Event *evPtr,		/* Event to add to queue. The storage space
				 * must have been allocated by the caller with
				 * malloc (Tcl_Alloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */
    int position)		/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
				 * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

/*
 * Commands in oo and oo::Helpers.
 */

static const struct StdCommands {
    const char *name;
    Tcl_ObjCmdProc *objProc;
    Tcl_ObjCmdProc *nreProc;
    CompileProc *compileProc;
    int flags;
} ooCmds[] = {
    {"define",		TclOODefineObjCmd, NULL, NULL, 0},
    {"objdefine",	TclOOObjDefObjCmd, NULL, NULL, 0},
    {"copy",		TclOOCopyObjectCmd, NULL, NULL, 0},
    {"DelegateName",	TclOODelegateNameObjCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, 0}
}, helpCmds[] = {
    {"callback",	TclOOCallbackObjCmd, NULL, NULL, 0},
    {"mymethod",	TclOOCallbackObjCmd, NULL, NULL, 0},
    {"classvariable",	TclOOClassVariableObjCmd, NULL, NULL, 0},
    {"link",		TclOOLinkObjCmd, NULL, NULL, 0},
    {"next",		NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED},
    {"nextto",		NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd, CMD_COMPILES_EXPANDED},
    {"self",		TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd, 0},
    {NULL, NULL, NULL, NULL, 0}
};

/*
 * Commands in oo::define and oo::objdefine.
 */

static const struct DefineCommands {
    const char *name;
    Tcl_ObjCmdProc *objProc;
    int flag;
} defineCmds[] = {
    {"classmethod",	TclOODefineClassMethodObjCmd, 0},
    {"constructor",	TclOODefineConstructorObjCmd, 0},
    {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 0},
    {"destructor",	TclOODefineDestructorObjCmd, 0},
    {"export",		TclOODefineExportObjCmd, 0},
    {"forward",		TclOODefineForwardObjCmd, 0},
    {"initialise",	TclOODefineInitialiseObjCmd, 0},
    {"initialize",	TclOODefineInitialiseObjCmd, 0},
    {"method",		TclOODefineMethodObjCmd, 0},
    {"private",		TclOODefinePrivateObjCmd, 0},
    {"renamemethod",	TclOODefineRenameMethodObjCmd, 0},
    {"self",		TclOODefineSelfObjCmd, 0},
    {"unexport",	TclOODefineUnexportObjCmd, 0},
    {NULL, NULL, 0}
}, objdefCmds[] = {
    {"class",		TclOODefineClassObjCmd, 1},
    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 1},
    {"export",		TclOODefineExportObjCmd, 1},
    {"forward",		TclOODefineForwardObjCmd, 1},
    {"method",		TclOODefineMethodObjCmd, 1},
    {"private",		TclOODefinePrivateObjCmd, 1},
    {"renamemethod",	TclOODefineRenameMethodObjCmd, 1},
    {"self",		TclOODefineObjSelfObjCmd, 0},
    {"unexport",	TclOODefineUnexportObjCmd, 1},
    {NULL, NULL, 0}
};

/*
 * What sort of size of things we like to allocate.
 */

#define ALLOC_CHUNK 8

/*
 * Function declarations for things defined in this file.
 */

static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
			    Namespace *nsPtr, const char *nsNameStr);
static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
			    Method *mPtr, Tcl_Obj *namePtr,
			    Method **newMPtrPtr);
static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
			    Method *mPtr, Tcl_Obj *namePtr);
static Tcl_NamespaceDeleteProc	DeletedHelpersNamespace;
static Tcl_NRPostProc	FinalizeAlloc;
static Tcl_NRPostProc	FinalizeNext;
static Tcl_NRPostProc	FinalizeObjectCall;
static inline void	InitClassPath(Tcl_Interp * interp, Class *clsPtr);
static void		InitClassSystemRoots(Tcl_Interp *interp,
			    Foundation *fPtr);
static int		InitFoundation(Tcl_Interp *interp);
static Tcl_InterpDeleteProc	KillFoundation;
static Tcl_CmdDeleteProc	MyDeleted;
static Tcl_NamespaceDeleteProc	ObjectNamespaceDeleted;
static Tcl_CommandTraceProc	ObjectRenamedTrace;
static inline void	RemoveClass(Class **list, size_t num, size_t idx);
static inline void	RemoveObject(Object **list, size_t num, size_t idx);
static inline void	SquelchCachedName(Object *oPtr);

static Tcl_ObjCmdProc	PublicNRObjectCmd;


static Tcl_ObjCmdProc	PrivateNRObjectCmd;


static Tcl_ObjCmdProc	MyClassNRObjCmd;


static Tcl_CmdDeleteProc	MyClassDeleted;

/*
 * Methods in the oo::object and oo::class classes. First, we define a helper
 * macro that makes building the method type declaration structure a lot
 * easier. No point in making life harder than it has to be!
 *
 * Note that the core methods don't need clone or free proc callbacks.

 */

static const char initScript[] =
#ifndef TCL_NO_DEPRECATED
"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
#endif
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo {"
"    variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL
"};";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */

/*
 * The scripted part of the definitions of TclOO.
 */

    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
    TclNewLiteralStringObj(fPtr->myName, "my");
    TclNewLiteralStringObj(fPtr->slotGetName, "Get");
    TclNewLiteralStringObj(fPtr->slotSetName, "Set");
    TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
    TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation");
    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
    Tcl_IncrRefCount(fPtr->constructorName);
    Tcl_IncrRefCount(fPtr->destructorName);
    Tcl_IncrRefCount(fPtr->clonedName);
    Tcl_IncrRefCount(fPtr->defineName);
    Tcl_IncrRefCount(fPtr->myName);
    Tcl_IncrRefCount(fPtr->slotGetName);
    Tcl_IncrRefCount(fPtr->slotSetName);
    Tcl_IncrRefCount(fPtr->slotResolveName);
    Tcl_IncrRefCount(fPtr->slotDefOpName);

    TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
	    TclOOUnknownDefinition, NULL, NULL);
    TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
    Tcl_SetNamespaceUnknownHandler(interp, define, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, objdef, namePtr);
    Tcl_BounceRefCount(namePtr);

	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */

    for (i = 0 ; helpCmds[i].name ; i++) {

	CreateCmdInNS(interp, fPtr->helpersNs, helpCmds[i].name,


		helpCmds[i].objProc, helpCmds[i].nreProc,
		helpCmds[i].compileProc, helpCmds[i].flags);
    }
    for (i = 0 ; ooCmds[i].name ; i++) {
	CreateCmdInNS(interp, fPtr->ooNs, ooCmds[i].name,
		ooCmds[i].objProc, ooCmds[i].nreProc,
		ooCmds[i].compileProc, ooCmds[i].flags);

    }

    TclOOInitInfo(interp);

    /*
     * Now make the class of slots.
     */

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);
    TclDecrRefCount(fPtr->myName);
    TclDecrRefCount(fPtr->slotGetName);
    TclDecrRefCount(fPtr->slotSetName);
    TclDecrRefCount(fPtr->slotResolveName);
    TclDecrRefCount(fPtr->slotDefOpName);
    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    Tcl_Free(fPtr);

    /*
     * Don't leave the interpreter field pointing to freed data.

    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
	    MyClassDeleted);
    oPtr->linkedCmdsList = NULL;
    return oPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * SquelchCachedName --

static void
MyDeleted(
    void *clientData)		/* Reference to the object whose [my] has been
				 * squelched. */
{
    Object *oPtr = (Object *) clientData;

    if (oPtr->linkedCmdsList) {
	Tcl_Size linkc, i;
	Tcl_Obj **linkv;
	TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv);
	for (i=0 ; i<linkc ; i++) {
	    Tcl_Obj *link = linkv[i];
	    (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link));
	}
	Tcl_DecrRefCount(oPtr->linkedCmdsList);
	oPtr->linkedCmdsList = NULL;
    }
    oPtr->myCommand = NULL;
}

static void
MyClassDeleted(
    void *clientData)
{

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the command that refers to the object at this point (if it
     * still exists) because otherwise its pointer to the object points into
     * freed memory.
     */

    if (((Command *) oPtr->command)->flags & CMD_DYING) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command

Tcl_Obj *
Tcl_GetObjectName(
    Tcl_Interp *interp,
    Tcl_Object object)
{
    return TclOOObjectName(interp, (Object *) object);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectMyName --
 *
 *	Utility function that returns the name of the object's [my], or NULL
 *	if it has been deleted (or otherwise doesn't exist).
 *
 * ----------------------------------------------------------------------
 */
Tcl_Obj *
TclOOObjectMyName(
    Tcl_Interp *interp,
    Object *oPtr)
{
    if (!oPtr->myCommand) {
	return NULL;
    }
    Tcl_Obj *namePtr;
    TclNewObj(namePtr);
    Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr);
    return namePtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * assorted trivial 'getter' functions
 *
 * ----------------------------------------------------------------------

#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclTomMath.h"

static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static Tcl_NRPostProc	AfterNRDestructor;
static Tcl_NRPostProc	PostClassConstructor;
static Tcl_NRPostProc	FinalizeConstruction;
static Tcl_NRPostProc	FinalizeEval;
static Tcl_NRPostProc	NextRestoreFrame;

/*
 * ----------------------------------------------------------------------
 *

    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * MixinClassDelegates --
 *
 *	Internal utility for setting up the class delegate.
 *	Runs after the class has called [oo::define] on its argument.
 *
 * ----------------------------------------------------------------------
 */

// Look up the delegate for a class.
static inline Class *
GetClassDelegate(
    Tcl_Interp *interp,
    Class *clsPtr)
{
    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName);
    Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
    Tcl_DecrRefCount(delegateName);
    return delegatePtr;
}

/*
 * Patches in the appropriate class delegates' superclasses.
 * Sonewhat messy because the list of superclasses isn't modified frequently.
 */
static inline void
SetDelegateSuperclasses(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    // Build new list of superclasses
    int i, j = delegatePtr->superclasses.num, k;
    Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
	    (delegatePtr->superclasses.num + clsPtr->superclasses.num));
    if (delegatePtr->superclasses.num) {
	memcpy(supers, delegatePtr->superclasses.list,
		sizeof(Class *) * delegatePtr->superclasses.num);
    }
    FOREACH(superPtr, clsPtr->superclasses) {
	Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
	if (!superDelegatePtr) {
	    continue;
	}
	for (k=0 ; k<=j ; k++) {
	    if (k == j) {
		supers[j++] = superDelegatePtr;
		TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
		AddRef(superDelegatePtr->thisPtr);
		break;
	    } else if (supers[k] == superDelegatePtr) {
		break;
	    }
	}
    }

    // Install new list of superclasses;
    if (delegatePtr->superclasses.num) {
	Tcl_Free(delegatePtr->superclasses.list);
    }
    delegatePtr->superclasses.list = supers;
    delegatePtr->superclasses.num = j;

    // Definitely don't need to bump any epoch here
}

/*
 * Mixes the delegate into its controlling class.
 */
static inline void
InstallDelegateAsMixin(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    if (clsPtr->thisPtr->mixins.num == 0) {
	TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
	return;
    }
    Class **mixins = (Class **) TclStackAlloc(interp,
	    sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
    for (int i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
	mixins[i] = clsPtr->thisPtr->mixins.list[i];
	if (mixins[i] == delegatePtr) {
	    TclStackFree(interp, (void *) mixins);
	    return;
	}
    }
    mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
    TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
    TclStackFree(interp, mixins);
}

// Patches in the appropriate class delegates.
static void
MixinClassDelegates(
    Tcl_Interp *interp,
    Object *oPtr,
    Tcl_Obj *delegateName)
{
    Class *clsPtr = oPtr->classPtr;
    if (clsPtr) {
	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
	if (delegatePtr) {
	    SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
	    InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
	}
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Constructor --
 *
 *	Implementation for oo::class constructor.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_Constructor(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);


    size_t skip = Tcl_ObjectContextSkippedArgs(context);
    if ((size_t) objc > skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv,
		"?definitionScript?");
	return TCL_ERROR;
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     *
     * This needs to be done before consideration of whether to pass the script
     * argument to [oo::define]. [Bug 680503]
     */

    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    oPtr->namespacePtr->fullName);
    Tcl_IncrRefCount(delegateName);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);


    /*
     * If there's nothing else to do, we're done.
     */

    if ((size_t) objc == skip) {
	Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
	MixinClassDelegates(interp, oPtr, delegateName);
	Tcl_DecrRefCount(delegateName);
	return Tcl_RestoreInterpState(interp, saved);
    }

    /*
     * Delegate to [oo::define] to do the work.
     */

    Tcl_Obj **invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc - 1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, PostClassConstructor,
	    invoke, oPtr, delegateName, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
}

/*
 *	Called *after* [oo::define] inside the constructor of a class.
 *	Cleans up some temporary storage and sets up the delegate.
 */
static int
PostClassConstructor(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = (Tcl_Obj **) data[0];
    Object *oPtr = (Object *) data[1];
    Tcl_Obj *delegateName = (Tcl_Obj *) data[2];


    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);








    TclStackFree(interp, invoke);




    Tcl_InterpState saved = Tcl_SaveInterpState(interp, result);
    MixinClassDelegates(interp, oPtr, delegateName);
    Tcl_DecrRefCount(delegateName);
    return Tcl_RestoreInterpState(interp, saved);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --

    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOLinkObjCmd --
 *
 *	Implementation of the [link] command, that makes a command that
 *	invokes a method on the current object. The name of the command and
 *	the name of the method match by default. Note that this command is
 *	only ever to be used inside the body of a procedure-like method,
 *	and is typically intended for constructors.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOLinkObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    // Set up common bits.
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }
    CallContext *context = (CallContext *) framePtr->clientData;
    Object *oPtr = context->oPtr;
    if (!oPtr->myCommand) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot link to non-existent callback handle"));
	OO_ERROR(interp, MY_GONE);
	return TCL_ERROR;
    }
    Tcl_Obj *myCmd = Tcl_NewObj();
    Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
    if (!oPtr->linkedCmdsList) {
	oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
	Tcl_IncrRefCount(oPtr->linkedCmdsList);
    }

    // For each argument
    for (int i=1; i<objc; i++) {
	Tcl_Size linkc;
	Tcl_Obj **linkv, *src, *dst;

	// Parse as list of (one or) two items: source and destination names
	if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    return TCL_ERROR;
	}
	switch (linkc) {
	case 1:
	    // Degenerate case
	    src = dst = linkv[0];
	    break;
	case 2:
	    src = linkv[0];
	    dst = linkv[1];
	    break;
	default:
	    Tcl_BounceRefCount(myCmd);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad link description; must only have one or two elements"));
	    OO_ERROR(interp, CMDLINK_FORMAT);
	    return TCL_ERROR;
	}

	// Qualify the source if necessary
	const char *srcStr = TclGetString(src);
	if (srcStr[0] != ':' || srcStr[1] != ':') {
	    src = Tcl_ObjPrintf("%s::%s",
		    context->oPtr->namespacePtr->fullName, srcStr);
	}

	// Make the alias command
	if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    Tcl_BounceRefCount(src);
	    return TCL_ERROR;
	}

	// Remember the alias for cleanup if necessary
	Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
    }
    Tcl_BounceRefCount(myCmd);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOONextObjCmd, TclOONextToObjCmd --
 *
 *	Implementation of the [next] and [nextto] commands. Note that these
 *	commands are only ever to be used inside the body of a procedure-like
 *	method.
 *
 * ----------------------------------------------------------------------

    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOCallbackObjCmd --
 *
 *	Implementation of the [callback] command, which constructs callbacks
 *	into the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOCallbackObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }

    CallContext *contextPtr = (CallContext *) framePtr->clientData;
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "method ...");
	return TCL_ERROR;
    }

    // Get the [my] real name.
    Tcl_Obj *namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
    if (!namePtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no possible safe callback without my", TCL_AUTO_LENGTH));
	OO_ERROR(interp, NO_MY);
	return TCL_ERROR;
    }

    // No check that the method exists; could be dynamically added.

    Tcl_Obj *listPtr = Tcl_NewListObj(1, &namePtr);
    (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassVariableObjCmd --
 *
 *	Implementation of the [classvariable] command, which links to
 *	variables in the class of the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOClassVariableObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ...");
	return TCL_ERROR;
    }

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }

    // Get a reference to the class's namespace
    CallContext *contextPtr = (CallContext *) framePtr->clientData;
    Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
    if (clsPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method not defined by a class", TCL_AUTO_LENGTH));
	OO_ERROR(interp, UNMATCHED_CONTEXT);
	return TCL_ERROR;
    }
    Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr;

    // Check the list of variable names
    for (int i = 1; i < objc; i++) {
	const char *varName = TclGetString(objv[i]);
	if (Tcl_StringMatch(varName, "*(*)")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "scalar variable that looks like an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*::*")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "local variable with a namespace separator in it"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
	    return TCL_ERROR;
	}
    }

    // Lastly, link the caller's local variables to the class's variables
    Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
    for (int i = 1; i < objc; i++) {
	// Locate the other variable.
	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
	Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
		"access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
	iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
	if (otherPtr == NULL) {
	    return TCL_ERROR;
	}

	// Create the new variable and link it to otherPtr.
	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
		TCL_INDEX_NONE) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODelegateNameObjCmd --
 *
 *	Implementation of the [oo::DelegateName] command, which is a utility
 *	that gets the name of the class delegate for a class. It's trivial,
 *	but makes working with them much easier as delegate names are
 *	intentionally hard to create by accident.
 *
 *	Not part of TclOO public API. No public documentation.
 *
 * ----------------------------------------------------------------------
 */
int
TclOODelegateNameObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 * Some things that make it easier to declare a slot.
 */
typedef struct DeclaredSlot {
    const char *name;
    const Tcl_MethodType getterType;
    const Tcl_MethodType setterType;
    const Tcl_MethodType resolverType;
    const char *defaultOp;	// The default op, if not set by the class
} DeclaredSlot;

#define SLOT(name,getter,setter,resolver,defOp) \
    {"::oo::" name,							\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
		    resolver, NULL, NULL}, (defOp)}

typedef struct DeclaredSlotMethod {
    const char *name;
    int flags;
    const Tcl_MethodType implType;
} DeclaredSlotMethod;

#define SLOT_METHOD(name,impl,flags) \
    {name, flags, {TCL_OO_METHOD_VERSION_1,				\
	    "core method: " name " slot", impl, NULL, NULL}}

/*
 * A [string match] pattern used to determine if a method should be exported.
 */

#define PUBLIC_PATTERN		"[a-z]*"

static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
static int		Slot_Append(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_AppendNew(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Clear(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Prepend(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Remove(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Resolve(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Set(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Unimplemented(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext,
			    int, Tcl_Obj *const *);
static int		Slot_Unknown(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilter_Get(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilter_Set(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixin_Get(void *clientData,

			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilter_Get, ClassFilter_Set, NULL, NULL),
    SLOT("define::mixin",       ClassMixin_Get,  ClassMixin_Set, ResolveClass, "-set"),
    SLOT("define::superclass",  ClassSuper_Get,  ClassSuper_Set, ResolveClass, "-set"),
    SLOT("define::variable",    ClassVars_Get,   ClassVars_Set, NULL, NULL),
    SLOT("objdefine::filter",   ObjFilter_Get,   ObjFilter_Set, NULL, NULL),
    SLOT("objdefine::mixin",    ObjMixin_Get,    ObjMixin_Set, ResolveClass, "-set"),
    SLOT("objdefine::variable", ObjVars_Get,     ObjVars_Set, NULL, NULL),
    SLOT("configuresupport::readableproperties",
	    Configurable_ClassReadableProps_Get,
	    Configurable_ClassReadableProps_Set, NULL, NULL),
    SLOT("configuresupport::writableproperties",
	    Configurable_ClassWritableProps_Get,
	    Configurable_ClassWritableProps_Set, NULL, NULL),
    SLOT("configuresupport::objreadableproperties",
	    Configurable_ObjectReadableProps_Get,
	    Configurable_ObjectReadableProps_Set, NULL, NULL),
    SLOT("configuresupport::objwritableproperties",
	    Configurable_ObjectWritableProps_Get,
	    Configurable_ObjectWritableProps_Set, NULL, NULL),
    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0}
};

static const DeclaredSlotMethod slotMethods[] = {
    SLOT_METHOD("Get",		Slot_Unimplemented, 0),
    SLOT_METHOD("Resolve",	Slot_Resolve,	0),
    SLOT_METHOD("Set",		Slot_Unimplemented, 0),
    SLOT_METHOD("-append",	Slot_Append,	PUBLIC_METHOD),
    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
    SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
    SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
    SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
    SLOT_METHOD("unknown",	Slot_Unknown,	0),
    {NULL, 0, {0, 0, 0, 0, 0}}
};

/*
 * How to build the in-namespace name of a private variable. This is a pattern
 * used with Tcl_ObjPrintf().
 */

    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod --
 *
 *	Exporting and unexporting are done by setting or removing the
 *	PUBLIC_METHOD flag on the method record. If there is no such method in
 *	this class or object (i.e. the method comes from something inherited
 *	from or that we're an instance of) then we put in a blank record just
 *	to hold that flag (or its absence); such records are skipped over by
 *	the call chain engine *except* for their flags member.
 *
 *	Caller has the responsibility to update any epochs if necessary.
 *
 * ----------------------------------------------------------------------
 */

// Make a blank method record or look up the existing one.
static inline Method *
GetOrCreateMethod(
    Tcl_HashTable *tablePtr,
    Tcl_Obj *namePtr,
    int *isNew)
{
    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr,
		    isNew);
    if (*isNew) {
	Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method));
	memset(mPtr, 0, sizeof(Method));
	mPtr->refCount = 1;
	mPtr->namePtr = namePtr;
	Tcl_IncrRefCount(namePtr);
	Tcl_SetHashValue(hPtr, mPtr);
	return mPtr;
    } else {
	return (Method *) Tcl_GetHashValue(hPtr);
    }
}

static int
ExportMethod(
    Class *clsPtr,
    Tcl_Obj *namePtr)
{
    int isNew;
    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
	mPtr->flags |= PUBLIC_METHOD;
	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
	isNew = 1;
    }
    return isNew;
}

static int
UnexportMethod(
    Class *clsPtr,
    Tcl_Obj *namePtr)
{
    int isNew;
    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
	isNew = 1;
    }
    return isNew;
}

// Make the table of methods in the instance if it doesn't already exist.
static inline void
InitMethodTable(
    Object *oPtr)
{
    if (!oPtr->methodsPtr) {
	oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
	Tcl_InitObjHashTable(oPtr->methodsPtr);
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
}

static int
ExportInstanceMethod(
    Object *oPtr,
    Tcl_Obj *namePtr)
{
    InitMethodTable(oPtr);

    int isNew;
    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
	mPtr->flags |= PUBLIC_METHOD;
	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
	isNew = 1;
    }
    return isNew;
}

static int
UnexportInstanceMethod(
    Object *oPtr,
    Tcl_Obj *namePtr)
{
    InitMethodTable(oPtr);

    int isNew;
    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
	isNew = 1;
    }
    return isNew;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineObjCmd --
 *
 *	Implementation of the "oo::define" command. Works by effectively doing
 *	the same as 'namespace eval', but with extra magic applied so that the
 *	object to be modified is known to the commands in the target
 *	namespace. Also does ensemble-like tricks with dispatch so that error
 *	messages are clearer.

TclOODefineExportObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceExport = (clientData != NULL);




    int i, changed = 0;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }

    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    Class *clsPtr = oPtr->classPtr;
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	OO_ERROR(interp, MONKEY_BUSINESS);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
	 * record. If there is no such method in this object or class (i.e.
	 * the method comes from something inherited from or that we're an
	 * instance of) then we put in a blank record with that flag; such
	 * records are skipped over by the call chain engine *except* for
	 * their flags member.
	 */

	if (isInstanceExport) {












	    changed |= ExportInstanceMethod(oPtr, objv[i]);







	} else {





	    changed |= ExportMethod(clsPtr, objv[i]);
	}
    }

    /*
     * Bump the right epoch if we actually changed anything.
     */

    }
    if (mPtr == NULL) {
	Tcl_DecrRefCount(prefixObj);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineInitialiseObjCmd --
 *
 *	Implementation of the "initialise" subcommand of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineInitialiseObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "body");
	return TCL_ERROR;
    }

    // Build the lambda
    Tcl_Object object = TclOOGetDefineCmdContext(interp);
    if (object == NULL) {
	return TCL_ERROR;
    }
    Tcl_Obj *lambdaWords[] = {
	Tcl_NewObj(),
	objv[1],
	TclNewNamespaceObj(Tcl_GetObjectNamespace(object))
    };

    // Delegate to [apply] to run it
    Tcl_Obj *applyArgs[] = {
	Tcl_NewStringObj("apply", -1),
	Tcl_NewListObj(3, lambdaWords)
    };
    Tcl_IncrRefCount(applyArgs[0]);
    Tcl_IncrRefCount(applyArgs[1]);
    int result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs);
    Tcl_DecrRefCount(applyArgs[0]);
    Tcl_DecrRefCount(applyArgs[1]);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineMethodObjCmd --
 *
 *	Implementation of the "method" subcommand of the "oo::define" and

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineClassMethodObjCmd --
 *
 *	Implementation of the "classmethod" subcommand of the "oo::define"
 *	command. Defines a class method. See define(n) for details.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineClassMethodObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    if (objc != 2 && objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    int isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;

    // Create the method on the delegate class if the caller gave arguments and body
    if (objc == 4) {
	Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
		clsPtr->thisPtr->namespacePtr->fullName);
	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
	Tcl_DecrRefCount(delegateName);
	if (!delegatePtr) {
	    return TCL_ERROR;
	}
	if (IsPrivateDefine(interp)) {
	    isPublic = 0;
	}
	if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1],
		objv[2], objv[3], NULL) == NULL) {
	    return TCL_ERROR;
	}
    }

    // Make the connection to the delegate by forwarding
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }
    Tcl_Obj *forwardArgs[] = {
	Tcl_NewStringObj("myclass", -1),
	objv[1]
    };
    Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs);
    Method *mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic,
	    objv[1], prefixObj);
    if (mPtr == NULL) {
	Tcl_DecrRefCount(prefixObj);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineRenameMethodObjCmd --
 *
 *	Implementation of the "renamemethod" subcommand of the "oo::define"
 *	and "oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceUnexport = (clientData != NULL);
    Object *oPtr;


    Class *clsPtr;
    int i, changed = 0;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	OO_ERROR(interp, MONKEY_BUSINESS);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {









	if (isInstanceUnexport) {












	    changed |= UnexportInstanceMethod(oPtr, objv[i]);







	} else {




	    changed |= UnexportMethod(clsPtr, objv[i]);
	}
    }

    /*
     * Bump the right epoch if we actually changed anything.
     */

}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineSlots --
 *
 *	Create the "::oo::Slot" class and its standard instances. These are
 *	basically lists at the low level of TclOO; this provides a more
 *	consistent interface to them.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineSlots(
    Foundation *fPtr)
{

    Tcl_Interp *interp = fPtr->interp;

    Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);


    if (object == NULL) {
	return TCL_ERROR;
    }
    Tcl_Class slotCls = (Tcl_Class) ((Object *) object)->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }

    for (const DeclaredSlotMethod *smPtr = slotMethods; smPtr->name; smPtr++) {
	Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1);
	Tcl_NewMethod(interp, slotCls, name, smPtr->flags,
		&smPtr->implType, NULL);
	Tcl_BounceRefCount(name);
    }

    // If a slot can't figure out what method to call directly, it uses
    // --default-operation. That defaults to -append; we set that here.
    Tcl_Obj *defaults[] = {
	fPtr->myName,
	Tcl_NewStringObj("-append", TCL_AUTO_LENGTH)
    };
    TclOONewForwardMethod(interp, (Class *) slotCls, 0,
	    fPtr->slotDefOpName, Tcl_NewListObj(2, defaults));

    // Hide the destroy method. (We're definitely taking a ref to the name.)
    UnexportMethod((Class *) slotCls,
	    Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH));

    for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) {
	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);


	if (slotObject == NULL) {
	    continue;
	}
	TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0,
		&slotPtr->getterType, NULL);
	TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0,
		&slotPtr->setterType, NULL);
	if (slotPtr->resolverType.callProc) {
	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
		    &slotPtr->resolverType, NULL);
	}
	if (slotPtr->defaultOp) {
	    Tcl_Obj *slotDefaults[] = {
		fPtr->myName,
		Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH)
	    };
	    TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0,
		    fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults));
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll --
 *
 *	How to call the standard low-level methods of a slot.
 *	ResolveAll is the lifting of CallSlotResolve to work over a whole
 *	list of items.
 *
 * ----------------------------------------------------------------------
 */

// Call [$slot Get] to retrieve the list of contents of the slot
static inline Tcl_Obj *
CallSlotGet(
    Tcl_Interp *interp,
    Object *slot)
{
    Tcl_Obj *getArgs[] = {
	slot->fPtr->myName,
	slot->fPtr->slotGetName
    };
    int code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs);
    if (code != TCL_OK) {
	return NULL;
    }
    return Tcl_GetObjResult(interp);
}

// Call [$slot Set $list] to set the list of contents of the slot
static inline int
CallSlotSet(
    Tcl_Interp *interp,
    Object *slot,
    Tcl_Obj *list)
{
    Tcl_Obj *setArgs[] = {
	slot->fPtr->myName,
	slot->fPtr->slotSetName,
	list
    };
    return TclOOPrivateObjectCmd(slot, interp, 3, setArgs);
}

// Call [$slot Resolve $item] to convert a slot item into canonical form
static inline Tcl_Obj *
CallSlotResolve(
    Tcl_Interp *interp,
    Object *slot,
    Tcl_Obj *item)
{
    Tcl_Obj *resolveArgs[] = {
	slot->fPtr->myName,
	slot->fPtr->slotResolveName,
	item
    };
    int code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs);
    if (code != TCL_OK) {
	return NULL;
    }
    return Tcl_GetObjResult(interp);
}

static inline Tcl_Obj *
ResolveAll(
    Tcl_Interp *interp,
    Object *slot,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * objc);
    for (int i = 0; i < objc; i++) {
	resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]);
	if (resolvedItems[i] == NULL) {
	    for (int j = 0; j < i; j++) {
		Tcl_DecrRefCount(resolvedItems[j]);
	    }
	    TclStackFree(interp, (void *) resolvedItems);
	    return NULL;
	}
	Tcl_IncrRefCount(resolvedItems[i]);
	Tcl_ResetResult(interp);
    }
    Tcl_Obj *resolvedList = Tcl_NewListObj(objc, resolvedItems);
    for (int i = 0; i < objc; i++) {
	TclDecrRefCount(resolvedItems[i]);
    }
    TclStackFree(interp, (void *) resolvedItems);
    return resolvedList;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Append --
 *
 *	Implementation of the "-append" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Append(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip == objc) {
	return TCL_OK;
    }

    // Resolve all values
    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    // Get slot contents; store in list
    Tcl_Obj *list = CallSlotGet(interp, oPtr);
    if (list == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);
    Tcl_ResetResult(interp);

    // Append
    if (Tcl_IsShared(list)) {
	Tcl_Obj *dup = Tcl_DuplicateObj(list);
	Tcl_IncrRefCount(dup);
	Tcl_DecrRefCount(list);
	list = dup;
    }
    if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) {
	Tcl_DecrRefCount(list);
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_DecrRefCount(resolved);

    // Set slot contents
    int code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_AppendNew --
 *
 *	Implementation of the "-appendifnew" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_AppendNew(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip == objc) {
	return TCL_OK;
    }

    // Resolve all values
    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    // Get slot contents; store in list
    Tcl_Obj *list = CallSlotGet(interp, oPtr);
    if (list == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);
    Tcl_ResetResult(interp);

    // Prepare a set of items in the list to set
    Tcl_Size listc;
    Tcl_Obj **listv;
    if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) {
	Tcl_DecrRefCount(list);
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_HashTable unique;
    Tcl_InitObjHashTable(&unique);
    for (Tcl_Size i=0 ; i<listc; i++) {
	Tcl_CreateHashEntry(&unique, listv[i], NULL);
    }

    // Append the new items if they're not already there
    if (Tcl_IsShared(list)) {
	Tcl_Obj *dup = Tcl_DuplicateObj(list);
	Tcl_IncrRefCount(dup);
	Tcl_DecrRefCount(list);
	list = dup;
    }
    TclListObjGetElements(NULL, resolved, &listc, &listv);
    for (Tcl_Size i=0 ; i<listc; i++) {
	int isNew;
	Tcl_CreateHashEntry(&unique, listv[i], &isNew);
	if (isNew) {
	    Tcl_ListObjAppendElement(interp, list, listv[i]);
	}
    }
    Tcl_DecrRefCount(resolved);
    Tcl_DeleteHashTable(&unique);

    // Set slot contents
    int code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Clear --
 *
 *	Implementation of the "-clear" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Clear(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip != objc) {
	Tcl_WrongNumArgs(interp, skip, objv, NULL);
	return TCL_ERROR;
    }
    Tcl_Obj *list = Tcl_NewObj();
    Tcl_IncrRefCount(list);
    int code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Prepend --
 *
 *	Implementation of the "-prepend" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Prepend(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip == objc) {
	return TCL_OK;
    }

    // Resolve all values
    Tcl_Obj *list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (list == NULL) {
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);

    // Get slot contents and append to list
    Tcl_Obj *oldList = CallSlotGet(interp, oPtr);
    if (oldList == NULL) {
	Tcl_DecrRefCount(list);
	return TCL_ERROR;
    }
    Tcl_ListObjAppendList(NULL, list, oldList);
    Tcl_ResetResult(interp);

    // Set slot contents
    int code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Remove --
 *
 *	Implementation of the "-remove" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Remove(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip == objc) {
	return TCL_OK;
    }

    // Resolve all values
    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    // Get slot contents; store in list
    Tcl_Obj *oldList = CallSlotGet(interp, oPtr);
    if (oldList == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(oldList);
    Tcl_ResetResult(interp);

    // Prepare a set of items in the list to remove
    Tcl_Size listc;
    Tcl_Obj **listv;
    TclListObjGetElements(NULL, resolved, &listc, &listv);
    Tcl_HashTable removeSet;
    Tcl_InitObjHashTable(&removeSet);
    for (Tcl_Size i=0 ; i<listc; i++) {
	Tcl_CreateHashEntry(&removeSet, listv[i], NULL);
    }
    Tcl_DecrRefCount(resolved);

    // Append the new items from the old items if they're not in the remove set
    if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) {
	Tcl_DecrRefCount(oldList);
	Tcl_DeleteHashTable(&removeSet);
	return TCL_ERROR;
    }
    Tcl_Obj *newList = Tcl_NewObj();
    for (Tcl_Size i=0 ; i<listc; i++) {
	if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) {
	    Tcl_ListObjAppendElement(NULL, newList, listv[i]);
	}
    }
    Tcl_DecrRefCount(oldList);
    Tcl_DeleteHashTable(&removeSet);

    // Set slot contents
    Tcl_IncrRefCount(newList);
    int code = CallSlotSet(interp, oPtr, newList);
    Tcl_DecrRefCount(newList);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Resolve --
 *
 *	Default implementation of the "Resolve" slot accessor. Just returns
 *	its argument unchanged; particular slots may override.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Resolve(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip + 1 != objc) {
	Tcl_WrongNumArgs(interp, skip, objv, "list");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, objv[objc - 1]);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Set --
 *
 *	Implementation of the "-set" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Set(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    Tcl_Obj *list;

    // Resolve all values
    if (skip == objc) {
	list = Tcl_NewObj();
    } else {
	list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
	if (list == NULL) {
	    return TCL_ERROR;
	}
    }
    Tcl_IncrRefCount(list);

    // Set slot contents
    int code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Unimplemented --
 *
 *	Default implementation of the "Get" and "Set" slot accessors. Just
 *	returns an error; actual slots must override.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Unimplemented(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(int),
    TCL_UNUSED(Tcl_Obj *const *))
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
    OO_ERROR(interp, ABSTRACT_SLOT);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Unknown --
 *
 *	Unknown method name handler for slots. Delegates to the default slot
 *	operation (--default-operation forwarded method) unless the first
 *	argument starts with a dash.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Unknown(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip >= objc) {
	Tcl_Obj *args[] = {
	    oPtr->fPtr->myName,
	    oPtr->fPtr->slotDefOpName
	};
	return TclOOPrivateObjectCmd(oPtr, interp, 2, args);
    } else if (TclGetString(objv[skip])[0] != '-') {
	Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp,
		sizeof(Tcl_Obj *) * (objc - skip + 2));
	args[0] = oPtr->fPtr->myName;
	args[1] = oPtr->fPtr->slotDefOpName;
	memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip));
	int code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args);
	TclStackFree(interp, args);
	return code;
    }
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassFilter_Get, ClassFilter_Set --
 *

				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this object *claims* to
				 * support. */
    Tcl_Obj *linkedCmdsList;	/* List of names of linked commands. */
};

enum ObjectFlags {
    OBJECT_DESTRUCTING = 1,	/* Indicates that an object is being or has
				 * been destroyed. */
    DESTRUCTOR_CALLED = 2,	/* Indicates that evaluation of destructor
				 * script for the object has began */

				 * constructor. */
    Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */
    Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
    Tcl_Obj *myName;		/* The "my" shared object. */
    Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
    Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
    Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
    Tcl_Obj *slotDefOpName;	/* The "--default-operation" name used by slots. */
};

/*
 * The number of MInvoke records in the CallChain before we allocate
 * separately.
 */
#define CALL_CHAIN_STATIC_SIZE 4

 * Commands relating to OO support.
 *----------------------------------------------------------------
 */

MODULE_SCOPE int		TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOObjDefObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineClassMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineConstructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDefnNsObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDeleteMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDestructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineExportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineForwardObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineInitialiseObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineRenameMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineUnexportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineClassObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOLinkObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOInfoObjectPropCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOInfoClassPropCmd;

/*

			    Tcl_Var *aryPtr);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
			    Tcl_ObjectContext context, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip);
MODULE_SCOPE void	TclOODefineBasicMethods(Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE Tcl_Obj *	TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE int	TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE int	TclOORemoveFromSubclasses(Class *subPtr,

 * contains the commented version of everything; *this* file is automatically
 * generated.
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"















































































































































































"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"

"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tset targetObject [self]\n"
"\t\tnext $originObject\n"
"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"\t\t\t\t}]\n"
"\t\t}\n"
"\t}\n"
"\tclass create singleton\n"
"\tdefine singleton superclass -set class\n"

"\tdefine singleton unexport create createWithNamespace\n"
"\tdefine singleton method new args {\n"
"\t\tvariable object\n"
"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\tset object [next {*}$args]\n"
"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n"









"\t\t}\n"
"\t\treturn $object\n"

"\t}\n"
"\tclass create SingletonInstance\n"
"\tdefine SingletonInstance method destroy {} {\n"
"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\"may not destroy a singleton object\"\n"
"\t}\n"
"\tdefine SingletonInstance method <cloned> -unexport {originObject} {\n"
"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\"may not clone a singleton object\"\n"
"\t}\n"
"\tclass create abstract\n"
"\tdefine abstract superclass -set class\n"
"\tdefine abstract unexport create createWithNamespace new\n"
"\tnamespace eval configuresupport::configurableclass {\n"

"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::define\n"
"\t\t::namespace export property\n"
"\t}\n"
"\tnamespace eval configuresupport::configurableobject {\n"
"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::objdefine\n"
"\t\t::namespace export property\n"





"\t}\n"



"\tdefine configuresupport::configurable {\n"
"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"

"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
"\tclass create configurable\n"
"\tdefine configurable superclass -set class\n"
"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
"\t\tnext $definitionScript\n"
"\t}\n"
"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
"}\n"
/* !END!: Do not edit above this line. */
;

#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    Tcl_Size length)		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If
				 * TCL_INDEX_NONE, use bytes up to the first NUL
				 * byte. */
{
    return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}

// Redefine the macro
#define Tcl_NewStringObj(bytes, len) \
     Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
    const char *bytes,		/* Points to the first of the length bytes
				 * used to initialize the new object. */
    Tcl_Size length)		/* The number of bytes to copy from "bytes"
				 * when initializing the new object. If -1,

	return objPtr->length;
    }

    /*
     * Optimize the case where we're really dealing with a byte-array object;
     * we don't need to convert to a string to perform the get-length operation.
     *
     * Starting in Tcl 9.0, we check for a "pure" byte-array, because the
     * machinery behind that test is using a proper byte-array ObjType.  We
     * could also compute length of an improper byte-array without shimmering
     * but there's no value in that. We *want* to shimmer an improper byte-array
     * because improper byte-arrays have worthless internal reps.
     */

    if (TclIsPureByteArray(objPtr)) {

	return objPtr->length;
    }

    /*
     * Optimize the case where we're really dealing with a byte-array object;
     * we don't need to convert to a string to perform the get-length operation.
     *
     * Starting in Tcl 9.0, we check for a "pure" byte-array, because the
     * machinery behind that test is using a proper byte-array ObjType.  We
     * could also compute length of an improper byte-array without shimmering
     * but there's no value in that. We *want* to shimmer an improper byte-array
     * because improper byte-arrays have worthless internal reps.
     */

    if (TclIsPureByteArray(objPtr)) {

    if (!stubsPtr || (stubsPtr->magic != magic)) {
	exact &= 0xFFFF00; /* Filter out minor/major Tcl version */
	if (!exact) {
	    exact = 0x060800;
	}
	if (stubsPtr && (stubsPtr->magic == TCL_STUB_MAGIC)
		&& ((exact|0x010000) == 0x070800)) {
	    /* We are running in Tcl 9.x, but extension is compiled with 8.6 */
	    stubsPtr->tcl_SetObjResult(interp, stubsPtr->tcl_ObjPrintf(
		    "this extension is compiled for Tcl %d.%d",
		    (exact & 0x0FF00)>>8, (exact & 0x0FF0000)>>16));
	} else if (stubsPtr && (stubsPtr->magic == (int)0xFCA3BACF)
		&& ((exact & 0x0FF00) >= 0x0900)) {
	    /* We are running in Tcl 8.x, but extension is compiled with 9.0+ */
	    char major[4], minor[4];

static int
TestCommonInit(
    Tcl_Interp *interp)		/* Interpreter for application. */
{
    Tcl_CmdInfo info;

    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
	if (info.isNativeObjectProc == 2) {
	    Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
		    info.objProc2, (void *)version, NULL);
	} else {

    return TCL_ERROR;
}

/*
 *  lgen package init
 */
int Lgen_Init(Tcl_Interp *interp) {
    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
    Tcl_PkgProvide(interp, "lgen", "1.0");
    return TCL_OK;
}


 *----------------------------------------------------------------------
 */

int
Tcl_ABSListTest_Init(
    Tcl_Interp *interp)
{
    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
    Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
    return TCL_OK;
}

     * An array of Tcl_Obj pointers used in the commands that operate on or get
     * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
     * Tcl_Obj *.
     */
    Tcl_Obj **varPtr;

#ifndef TCL_WITH_EXTERNAL_TOMMATH
    if (Tcl_TomMath_InitStubs(interp, "9.0-") == NULL) {
	return TCL_ERROR;
    }
#endif
    varPtr = (Tcl_Obj **)Tcl_Alloc(NUMBER_OF_OBJECT_VARS * sizeof(varPtr[0]));
    if (!varPtr) {
	return TCL_ERROR;
    }

 *
 * TestlistobjCmd --
 *
 *	This function implements the 'testlistobj' command. It is used to
 *	test a few possible corner cases in list object manipulation from
 *	C code that cannot occur at the Tcl level.
 *
 *      Following new commands are added for 9.0 as regression tests for
 *      memory leaks and use-after-free. Unlike 8.6, 9.0 has multiple internal
 *      representations for lists.  It has to be ensured that corresponding
 *      implementations obey the invariants of the C list API. The script
 *      level tests do not suffice as Tcl list commands do not execute
 *      the same exact code path as the exported C API.
 *
 *      Note these new commands are only useful when Tcl is compiled with
 *      TCL_MEM_DEBUG defined.

static int		InitReadableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z);
static int		InitWritableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z, int trunc);
static int		ListMountPoints(Tcl_Interp *interp);
static int		ContainsMountPoint(const char *path, int pathLen);
static void		CleanupMount(ZipFile *zf);

static void		SerializeCentralDirectoryEntry(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    ZipEntry *z, size_t nameLength,
			    long long dataStartOffset);
static void		SerializeCentralDirectorySuffix(
			    const unsigned char *start,

	Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p",
		bufferStart, bufferEnd, ptr);
    }
    ptr[0] = value & 0xff;
    ptr[1] = (value >> 8) & 0xff;
}

/*
 * Need a separate mutex for locating libraries because the search calls
 * TclZipfs_Mount which takes out a write lock on the ZipFSMutex. Since
 * those cannot be nested, we need a separate mutex.
 */
TCL_DECLARE_MUTEX(ZipFSLocateLibMutex)

/*
 *-------------------------------------------------------------------------
 *
 * ReadLock, WriteLock, Unlock --
 *
 *	POSIX like rwlock functions to support multiple readers and single
 *	writer on internal structs.

static char *
DecodeZipEntryText(
    const unsigned char *inputBytes,
    unsigned int inputLength,
    Tcl_DString *dstPtr)	/* Must have been initialized by caller! */
{
    Tcl_Encoding encoding;





    if (inputLength < 1) {
	return Tcl_DStringValue(dstPtr);
    }

    /*
     * We Tcl_ExternalToUtfDStringEx because that can report if it failed,
     * allowing us to try a different encoding.

     *
     * The UTF-8 encoding is implemented internally, and so is guaranteed to
     * be present. Tcl's own startup files (including the encoding definitions)
     * should all have ASCII filenames, which is a subset of UTF-8, and so they
     * should all work via this.
     */

    if (Tcl_ExternalToUtfDStringEx(NULL, tclUtf8Encoding,
	    (const char *) inputBytes, inputLength,



	    TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL) == TCL_OK) {








	return Tcl_DStringValue(dstPtr);













    }

    /*
     * Something went wrong. Fall back to another encoding. Those *can* use
     * Tcl_ExternalToUtfDString().
     */

	}
    }
    Unlock();
    return TCL_OK;
}

/*


 * TclZipfsLocateTclLibrary --
 *
 *	This procedure locates the root that Tcl's library files are mounted
 *	under if they are under a zipfs file system.
 *
 * Results:

 *	TCL_OK if the library was found, TCL_ERROR otherwise.
 *
 * Side effects:
 *	Initializes the global variable zipfs_literal_tcl_library. Will
 *	never be cleared.
 *
 *-------------------------------------------------------------------------
 */








int
















TclZipfsLocateTclLibrary(void)
{
    Tcl_Obj *vfsInitScript;
    int found;
#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(STATIC_BUILD)
#   define LIBRARY_SIZE	    64
    HMODULE hModule;
    WCHAR wName[MAX_PATH + LIBRARY_SIZE];
    char dllName[(MAX_PATH + LIBRARY_SIZE) * 3];
#endif /* _WIN32 */






    if (zipfs_tcl_library_init) {
	return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;

    }

    Tcl_MutexLock(&ZipFSLocateLibMutex);
    if (zipfs_tcl_library_init) {
	/* Some other thread won the race */
	Tcl_MutexUnlock(&ZipFSLocateLibMutex);
	return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;
    }


    /* Look for the library file system within the executable. */

    vfsInitScript =
	Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", -1);

    Tcl_IncrRefCount(vfsInitScript);
    found = Tcl_FSAccess(vfsInitScript, F_OK);
    Tcl_DecrRefCount(vfsInitScript);
    if (found == TCL_OK) {
	zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
	goto unlock_and_return;
    }

    /*
     * Look for the library file system within the DLL/shared
     * library.  Note that we must mount the zip file and dll before
     * releasing to search.
     */

#if !defined(STATIC_BUILD)
#if defined(_WIN32) || defined(__CYGWIN__)
    hModule = (HMODULE)TclWinGetTclInstance();
    GetModuleFileNameW(hModule, wName, MAX_PATH);
#ifdef __CYGWIN__
    cygwin_conv_path(3, wName, dllName, sizeof(dllName));
#else
    WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
#endif

    if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
	goto unlock_and_return;
    }
#elif !defined(NO_DLFCN_H)
    Dl_info dlinfo;
    if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
	    && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
	goto unlock_and_return;
    }
#else
    if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
	goto unlock_and_return;
    }
#endif /* _WIN32 */
#endif /* !defined(STATIC_BUILD) */

unlock_and_return:
    zipfs_tcl_library_init = 1;
    Tcl_MutexUnlock(&ZipFSLocateLibMutex);
    return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;
}

/*

 *-------------------------------------------------------------------------
 *
 * TclZipfs_TclLibrary --
 *
 *	This procedure gets the root that Tcl's library
 *	files are mounted under if they are under a zipfs file system.
 *
 * Results:
 *	A Tcl object holding the location (with zero refcount), or NULL if no
 *	Tcl library can be found.
 *
 *-------------------------------------------------------------------------
 */

Tcl_Obj *
TclZipfs_TclLibrary(void)

{
    /*

     * Assumes TclZipfsLocateTclLibrary has already been called at startup
     * through Tcl_InitSubsystems.
     */
    assert(zipfs_tcl_library_init);
    if (zipfs_literal_tcl_library) {
	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    }
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSTclLibraryObjCmd --

	ZipFS.fallbackEntryEncoding = NULL;
    }

    ZipFS.initialized = 0;
    Unlock();
}

/*
 * TclZipfsInitEncodingDirs --
 *
 *	Sets the encoding directory search path to the encoding directory
 *	under the tcl_library directory within a ZipFS mount. Overwrites the
 *	previously set encoding search path so only to be called at
 *	initialization.
 */
static int
TclZipfsInitEncodingDirs(void)
{
    if (zipfs_literal_tcl_library == NULL) {
	return TCL_ERROR;
    }
    Tcl_Obj *libDirObj = Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
    Tcl_Obj *subDirObj, *searchPathObj;

    TclNewLiteralStringObj(subDirObj, "encoding");
    Tcl_IncrRefCount(subDirObj);
    TclNewObj(searchPathObj);
    Tcl_ListObjAppendElement(NULL, searchPathObj,
	    Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
    Tcl_DecrRefCount(subDirObj);
    Tcl_IncrRefCount(searchPathObj);
    Tcl_SetEncodingSearchPath(searchPathObj);
    Tcl_DecrRefCount(searchPathObj);
    /* Reinit system encoding after setting search path */
    TclpSetInitialEncodings();
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_AppHook --
 *
 *	Performs the argument munging for the shell
 *

#ifdef _WIN32
    result = Tcl_FindExecutable(NULL);
#else
    result = Tcl_FindExecutable((*argvPtr)[0]);
#endif
    archive = Tcl_GetNameOfExecutable();
    TclZipfs_Init(NULL);

    /*
     * Look for init.tcl in one of the locations mounted later in this
     * function. Errors ignored as other locations may be available.
     */
    if (TclZipfsLocateTclLibrary() == TCL_OK) {
	(void) TclZipfsInitEncodingDirs();
    }

    if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
	int found;
	Tcl_Obj *vfsInitScript;

	TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
	Tcl_IncrRefCount(vfsInitScript);

    # Select the locale, eventually load it
    mcpackagelocale set $locale
    return $locale
}

#----------------------------------------------------------------------
#
# _registryExists --
# _hasRegistry --
#
#	Helpers that checks whether registry module is available (Windows only)
#	and loads it on demand.
#
# Side effects:
#	_hasRegistry does it only once, and hereafter simply returns 1 or 0.
#
#----------------------------------------------------------------------
proc ::tcl::clock::_registryExists {} {

    if { $::tcl_platform(platform) eq {windows} } {
	if { [catch { package require registry 1.3 }] } {
	    # try to load registry directly from root (if uninstalled / development env):
	    if {[regexp {[/\\]library$} [info library]]} {catch {
		load [lindex \
			[glob -tails -directory [file dirname [info nameofexecutable]] \
			    tcl9registry*[expr {[::tcl::pkgconfig get debug] ? {g} : {}}].dll] 0 \
		] Registry
	    }}
	}
	if { [namespace which -command ::registry] ne "" } {
	    return 1
	}
    }
    return 0
}
proc ::tcl::clock::_hasRegistry {} {
    set res [_registryExists]
    proc ::tcl::clock::_hasRegistry {} [list return $res]
    return $res
}

#----------------------------------------------------------------------
#
# LoadWindowsDateTimeFormats --

if {![package vsatisfies [package provide Tcl] 9.0-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded dde 1.5a1 \
	[list load [file join $dir tcl9dde15.dll] Dde]

#
# All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require -exact tcl 9.1a1

# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
#
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.

###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
  set isafe [interp issafe]
  foreach {safe package version file} {
    0 http            2.10.0 {http http.tcl}
    1 msgcat          1.7.1  {msgcat msgcat.tcl}
    1 opt             0.4.9  {opt optparse.tcl}
    0 cookiejar       0.2.0  {cookiejar cookiejar.tcl}
    0 tcl::idna       1.0.1  {cookiejar idna.tcl}
    0 platform        1.1.0  {platform platform.tcl}
    0 platform::shell 1.1.4  {platform shell.tcl}
    1 tcltest         2.5.10 {tcltest tcltest.tcl}
  } {
    if {$isafe && !$safe} continue
    package ifneeded $package $version  [list source [file join $dir {*}$file]]
  }
}} $dir

package ifneeded platform        1.1.0 [list source -encoding utf-8 [file join $dir platform.tcl]]
package ifneeded platform::shell 1.1.4 [list source -encoding utf-8 [file join $dir shell.tcl]]

		# sparc
		if {$tcl_platform(wordSize) == 8} {
		    append cpu 64
		}
	    }
	}
	darwin {
	    set major [lindex [split $tcl_platform(osVersion) .] 0]
	    if {$major > 19} {
		set plat macos
	    } else {
		set plat macosx
	    }
	    # Correctly identify the cpu when running as a 64bit
	    # process on a machine with a 32bit kernel
	    if {$cpu eq "ix86"} {
		if {$tcl_platform(wordSize) == 8} {
		    set cpu x86_64
		}
	    }

proc ::platform::identify {} {
    global tcl_platform

    set id [generic]
    regexp {^([^-]+)-([^-]+)$} $id -> plat cpu

    switch -glob -- $plat {
	solaris {
	    regsub {^5} $tcl_platform(osVersion) 2 text
	    append plat $text
	    return "${plat}-${cpu}"
	}
	macos* {
	    set major [lindex [split $tcl_platform(osVersion) .] 0]
	    if {$major > 19} {
		incr major
		if {$major < 26} {
		    incr major -10
		}
		append plat $major
	    } else {
		incr major -4
		append plat 10.$major

	    }
	    return "${plat}-${cpu}"
	}
	linux {
	    # Look for the libc*.so and determine its version
	    # (libc5/6, libc6 further glibc 2.X)

	}
	macosx-x86_64 {
	    lappend res macosx-i386-x86_64
	}
	macosx-ix86 {
	    lappend res macosx-universal macosx-i386-x86_64
	}
	macos*-*    {
	    # 10.5+,11.0+
	    if {[regexp {macosx?([^-]*)-(.*)} $id -> v cpu]} {

		foreach {major minor} [split $v.15 .] break
		switch -exact -- $cpu {
		    ix86    {
			lappend alt i386-x86_64
			lappend alt universal
		    }
		    x86_64  {
			if {$major < 11 && $minor < 15} {
			    set alt i386-x86_64
			} else {
			    set alt {}
			}
		    }
		    arm  {
			lappend alt x86_64
		    }
		    default { set alt {} }
		}

		if {$v ne ""} {


		    set res {}
		    while {$major > 10} {
			# Add $major to patterns.

			lappend res macos${major}-${cpu}
			foreach a $alt {
			    lappend res macos${major}-$a
			}

			incr major -1
			if {$major == 25} {
			    set major 15
			}

		    }
		    # Add 10.9 to 10.minor to patterns.
		    for {set j $minor} {$j >= 9} {incr j -1} {

			if {$cpu ne "arm"} {
			    lappend res macosx${major}.${j}-${cpu}
			}

			if {($cpu eq "x86_64") && ($j == 14) && ![package vsatisfies [package provide Tcl] 9.0-]} {
			    set alt i386-x86_64

			}




			foreach a $alt {
			    lappend res macosx${major}.${j}-$a
			}
		    }
		    if {![package vsatisfies [package provide Tcl] 9.0-]} {
			# Continue up to 10.5.



			for {} {$j >= 5} {incr j -1} {
			    if {$cpu ne "arm"} {
				lappend res macosx${major}.${j}-${cpu}
			    }
			    foreach a $alt {
				lappend res macosx${major}.${j}-$a
			    }
			}

			# Add unversioned patterns for 10.3/10.4 builds.
			lappend res macosx-${cpu}
			foreach a $alt {
			    lappend res macosx-$a
			}
		    }
		} else {
		    # No version, just do unversioned patterns.
		    foreach a $alt {
			lappend res macosx-$a
		    }
		}
	    } else {
		# no v, no cpu ... nothing
	    }
	}
    }
    lappend res tcl ; # Pure tcl packages are always compatible.
    return $res
}


# ### ### ### ######### ######### #########
## Ready

package provide platform 1.1.0

# ### ### ### ######### ######### #########
## Demo application

if {[info exists argv0] && ($argv0 eq [info script])} {
    puts ====================================
    parray tcl_platform

if {![package vsatisfies [package provide Tcl] 9.0-]} return
if {[info sharedlibextension] != ".dll"} return
package ifneeded registry 1.4a1 \
	[list load [file join $dir tcl9registry14.dll] Registry]

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.5.10 [list source -encoding utf-8 [file join $dir tcltest.tcl]]

# All rights reserved.

namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.5.10

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package require] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package require Tcl 8.5-]
    variable patchLevel [info patchlevel]

		"Skipping test files that match:  [skipFiles]"
    }
    if {[llength [matchFiles]] > 0} {
	puts [outputChannel] \
		"Only running test files that match:  [matchFiles]"
    }

    set timeCmd {clock format now -format "%Y-%m-%d %H:%M:%S %Z" -locale en}
    puts [outputChannel] "Tests began at [eval $timeCmd]"

    # Run each of the specified tests
    foreach file [lsort [GetMatchingFiles]] {
	set tail [file tail $file]
	puts [outputChannel] $tail
	flush [outputChannel]

    u_int16_t fdFlags;
    u_int32_t location;
    u_int16_t reserved;
    u_int32_t extendedFileInfo[4];
} __attribute__ ((__packed__)) finderinfo;

typedef struct {
    u_int64_t reserved1; /* Make sure data is 8-byte aligned */
    u_int32_t reserved2; /* See [992f94d847] */
    u_int32_t info_length;
    u_int32_t data[8];
} fileinfobuf;

/*
 *----------------------------------------------------------------------
 *

    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
	alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
	alist.commonattr = ATTR_CMN_FNDRINFO;
    }
    native = (const char *)Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo.info_length,
	    sizeof(fileinfobuf) - offsetof(fileinfobuf, info_length), 0);

    if (result != 0) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"could not read attributes of \"%s\": %s",
		TclGetString(fileName), Tcl_PosixError(interp)));
	return TCL_ERROR;
    }

    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
	alist.fileattr = ATTR_FILE_RSRCLENGTH;
    } else {
	alist.commonattr = ATTR_CMN_FNDRINFO;
    }
    native = (const char *)Tcl_FSGetNativePath(fileName);
    result = getattrlist(native, &alist, &finfo.info_length,
	    sizeof(fileinfobuf) - offsetof(fileinfobuf, info_length), 0);

    if (result != 0) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"could not read attributes of \"%s\": %s",
		TclGetString(fileName), Tcl_PosixError(interp)));
	return TCL_ERROR;
    }

	Tcl_DString srcBuf, dstBuf;
	int result;

	bzero(&alist, sizeof(struct attrlist));
	alist.bitmapcount = ATTR_BIT_MAP_COUNT;
	alist.commonattr = ATTR_CMN_FNDRINFO;

	if (getattrlist(src, &alist, &finfo.info_length,
		sizeof(fileinfobuf) - offsetof(fileinfobuf, info_length), 0)) {
	    return TCL_ERROR;
	}
	if (setattrlist(dst, &alist, &finfo.data, sizeof(finfo.data), 0)) {
	    return TCL_ERROR;
	}

	/*

	/*
	 * We only copy a non-empty resource fork, so determine if that's the
	 * case first.
	 */

	alist.commonattr = 0;
	alist.fileattr = ATTR_FILE_RSRCLENGTH;
	if (getattrlist(src, &alist, &finfo.info_length,
		sizeof(fileinfobuf) - offsetof(fileinfobuf, info_length), 0)) {
	    return TCL_ERROR;
	} else if (*rsrcForkSize == 0) {
	    return TCL_OK;
	}

	/*
	 * Construct paths to resource forks.

    fileinfobuf finfo;
    finderinfo *finder = (finderinfo *) &finfo.data;
    OSType osType;

    bzero(&alist, sizeof(struct attrlist));
    alist.bitmapcount = ATTR_BIT_MAP_COUNT;
    alist.commonattr = ATTR_CMN_FNDRINFO;
    if (getattrlist(pathName, &alist, &finfo.info_length,
	    sizeof(fileinfobuf) - offsetof(fileinfobuf, info_length), 0)) {
	return 0;
    }
    if ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
	    !((finder->fdFlags & kFinfoIsInvisible) || (*fileName == '.'))) {
	return 0;
    }
    if (S_ISDIR(statBufPtr->st_mode)

		  Bias 300 \
		  StandardBias 0 \
		  DaylightBias -60 \
		  StandardStart \x00\x00\x0B\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \
		  DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]]
}


proc ::testClock::registry { cmd path key } {
    variable reg
    if { $cmd ne {get} } {
	return -code error "test case attempts to write/query the registry"
    }
    if { ![dict exists $reg $path $key] } {
	return -code error "test case attempts to read unknown registry entry $path $key"
    }
    return [dict get $reg $path $key]
}
proc ::testClock::_setupRegistry {} {
    rename ::tcl::clock::_hasRegistry ::tcl::clock::_org_hasRegistry
    proc ::tcl::clock::_hasRegistry {} {return 1}
    namespace eval ::tcl::clock {
	namespace import -force ::testClock::registry
    }
    ::tcl::clock::ClearCaches
}
proc ::testClock::_cleanupRegistry {} {
    if {[namespace which -command ::tcl::clock::registry] ne ""} {
	rename ::tcl::clock::registry {}
    }
    rename ::tcl::clock::_hasRegistry {}
    rename ::tcl::clock::_org_hasRegistry ::tcl::clock::_hasRegistry
    ::tcl::clock::ClearCaches
}

proc ::testClock::_setupNoTZ {} {
    if { [info exists ::env(TZ)] } {
	variable orgTZ $::env(TZ)
	unset ::env(TZ)
    }
    if { [info exists ::env(TCL_TZ)] } {
	variable orgTclTZ $::env(TCL_TZ)
	unset ::env(TCL_TZ)
    }
}
proc ::testClock::_cleanupNoTZ {} {
    variable orgTclTZ
    if { [info exists orgTclTZ] } {
	set ::env(TCL_TZ) $orgTclTZ
    } else {
	unset -nocomplain ::env(TCL_TZ)
    }
    variable orgTZ
    if { [info exists orgTZ] } {
	set ::env(TZ) $orgTZ
    } else {
	unset -nocomplain ::env(TZ)
    }
}

# Don't confuse all following tests with TZ or TCL_TZ environment vars (unset them here):
::testClock::_setupNoTZ

# Base test cases:

# no lazy creation of clock-ensemble (interim, bug [9889f96f4da77e3b], [31fd84270644f67d]),
# so ensemble created implicitely in init.tcl
test clock-0.1 "initial: auto-loading of ensemble and stubs on demand" -setup {
    set i [interp create]; # because clock can be used somewhere, test it in new interp:

# END testcases30


test clock-31.1 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry




    } \
    -body {
	clock format 0 -timezone :UTC -locale system -format %x
    } \
    -cleanup {

	::testClock::_cleanupRegistry



    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {%d-%b-%Y}]

test clock-31.2 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry




    } \
    -body {
	clock format 0 -timezone :UTC -locale system -format %Ex
    } \
    -cleanup {

	::testClock::_cleanupRegistry



    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {the %d' day of %B %Y}]

test clock-31.3 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry




    } \
    -body {
	clock format 0 -timezone :UTC -locale system -format %X
    } \
    -cleanup {

	::testClock::_cleanupRegistry



    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {%l:%M:%S %p}]

test clock-31.4 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry












    } \
    -body {
	clock format 0 -locale system -format %x
    } \
    -cleanup {

	::testClock::_cleanupRegistry









    } \
    -result [clock format 0 -locale current -timezone EST5 \
		 -format {%d-%b-%Y}]

test clock-31.5 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry












    } \
    -body {
	clock format 0 -locale system -format %Ex
    } \
    -cleanup {

	::testClock::_cleanupRegistry









    } \
    -result [clock format 0 -locale current -timezone EST5 \
		 -format {the %d' day of %B %Y}]

test clock-31.6 {system locale} \
    -constraints {win noappverifier} \
    -setup {

	::testClock::_setupRegistry












    } \
    -body {
	clock format 0 -locale system -format "%X %Z"
    } \
    -cleanup {

	::testClock::_cleanupRegistry









    } \
    -result [clock format 0 -locale current -timezone EST5 \
		 -format {%l:%M:%S %p %Z}]

test clock-32.1 {scan/format across the Gregorian change} {
    set problems {}
    set t [expr { wide(-6857395200) }]

    set d [clock scan $s -format %Es -gmt 1]
    # %Es depend on the time zone (local seconds instead of posix seconds).
    list [expr {$b-$a}] [expr {$d-$c}]
} {-7200 7200}

test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \
    -setup {



	set env(TZ) CET-01:00CEST-02:00,M3.5.0/02:00,M10.5.0/03:00
    } \
    -body {
	clock format 0 -format %H:%M:%S -timezone :localtime
    } \
    -cleanup {


	unset -nocomplain env(TZ)



    } \
    -result {01:00:00}

test clock-38.2 {make sure TZ is not cached after unset} \










    -body {
	set t1 [clock format 0 -locale en]
	# a time zone that is unlikely to anywhere
	set env(TZ) "+04:20"
	set t2 [clock format 0 -locale en]
	unset -nocomplain env(TZ)
	set t3 [clock format 0 -locale en]
	list [expr {$t1 eq $t3 && $t1 ne $t2}] [subst {"$t1" eq "$t3" && "$t1" ne "$t2"}]
    } \
    -cleanup {


	unset -nocomplain env(TZ)





    } \
    -match glob -result {1 *}

test clock-38.3sc {ensure cache of base is correct for :localtime if TZ-env changing / scan} \





    -body {
	set res {}
	foreach env(TZ) {GMT-11:30 GMT-07:30 GMT-03:30 GMT} \
		i {{07:30:00} {03:30:00} {23:30:00} {20:00:00}} \
	{
	    lappend res [clock scan $i -format "%H:%M:%S" -base [expr {20*60*60}] -timezone :localtime]
	}
	set res
    } \
    -cleanup {


	unset -nocomplain env(TZ)



    } \
    -result [lrepeat 4 [expr {20*60*60}]]
test clock-38.3fm {ensure cache of base is correct for :localtime if TZ-env changing / format} \





    -body {
	set res {}
	foreach env(TZ) {GMT-11:30 GMT-07:30 GMT-03:30 GMT} {
	    lappend res [clock format [expr {20*60*60}] -format "%Y-%m-%dT%H:%M:%S %Z" -timezone :localtime]
	}
	set res
    } \
    -cleanup {
	unset -nocomplain env(TZ)
    } \
    -result {{1970-01-02T07:30:00 +1130} {1970-01-02T03:30:00 +0730} {1970-01-01T23:30:00 +0330} {1970-01-01T20:00:00 +0000}}

test clock-38.4sc {ensure cache of base is correct for :localtime if TZ-env changing / scan (system TZ, no registry)} \
    -setup {
	::testClock::_setupRegistry
	# simulate we have no registry, so system TZ and :localtime get +HHMM format
	proc ::tcl::clock::_hasRegistry {} {return 0}
    } -body {
	# force epoch switch and set first TZ (a time zone that is unlikely to anywhere) and use :localtime
	set env(TZ) "+03:20"
	clock scan "12:00:00" -format "%H:%M:%S" -base [expr {20*60*60}] -timezone :localtime -locale en
	# force epoch switch, with unset TZ, it shall be system timezone now
	unset -nocomplain env(TZ)
	set t1 [clock scan "12:00:00" -format "%H:%M:%S" -base [expr {20*60*60}] -locale en]
	# force epoch switch and set another TZ (a time zone that is unlikely to anywhere) and use system timezone
	set env(TZ) "+04:20"
	set t2 [clock scan "12:00:00" -format "%H:%M:%S" -base [expr {20*60*60}] -locale en]
	# force epoch switch, with unset TZ, it shall be again system timezone
	unset -nocomplain env(TZ)
	set t3 [clock scan "12:00:00" -format "%H:%M:%S" -base [expr {20*60*60}] -locale en]
	# compare scanned values (t1 must be equal t3 and not equal t2):
	list [expr {$t1 == $t3 && $t1 != $t2}] [subst {$t1 == $t3 && $t1 != $t2}]
    } -cleanup {
	unset -nocomplain env(TZ)
	::testClock::_cleanupRegistry
    } -match glob -result {1 *}
test clock-38.4fm {ensure cache of base is correct for :localtime if TZ-env changing / format (system TZ, no registry)} \
    -setup {
	::testClock::_setupRegistry
	# simulate we have no registry, so system TZ and :localtime get +HHMM format
	proc ::tcl::clock::_hasRegistry {} {return 0}
    } -body {
	# force epoch switch and set first TZ (a time zone that is unlikely to anywhere) and use :localtime
	set env(TZ) "+03:20"

	clock format 0  -timezone :localtime -locale en
	# force epoch switch, with unset TZ, it shall be system timezone now
	unset -nocomplain env(TZ)
	set t1 [clock format 0 -locale en]
	# force epoch switch and set another TZ (a time zone that is unlikely to anywhere) and use system timezone
	set env(TZ) "+04:20"
	set t2 [clock format 0 -locale en]
	# force epoch switch, with unset TZ, it shall be again system timezone
	unset -nocomplain env(TZ)
	set t3 [clock format 0 -locale en]
	# compare formatted values (t1 must be equal t3 and not equal t2):
	list [expr {$t1 eq $t3 && $t1 ne $t2}] [subst {"$t1" eq "$t3" && "$t1" ne "$t2"}]
    } -cleanup {
	unset -nocomplain env(TZ)
	::testClock::_cleanupRegistry
    } -match glob -result {1 *}

test clock-39.1 {regression - synonym timezones} {
    clock format 0 -format {%H:%M:%S} -timezone :US/Eastern
} {19:00:00}

test clock-40.1 {regression - bad month with -timezone :localtime} \
    -setup {



	set env(TZ) UTC0
    } \
    -body {
	clock scan 2000-01-01T00:00:00 -timezone :localtime \
	    -format %Y-%m-%dT%H:%M:%S
    } \
    -cleanup {


	unset -nocomplain env(TZ)



    } \
    -result 946684800

test clock-41.1 {regression test - format group %k when hour is 0 } {
    clock format 0 -format %k -gmt true
} { 0}

test clock-42.1 {regression test - %z in :localtime when west of Greenwich } \
    -setup {



	set env(TZ) EST5
    } \
    -body {
	clock format 0 -format %z -timezone :localtime
    } \
    -cleanup {


	unset -nocomplain env(TZ)



    } \
    -result {-0500}

# 43.1 was a bad test - mktime returning -1 is an error according to Posix.

test clock-44.1 {regression test - time zone name containing hyphen } \
    -setup {



	set env(TZ) US/East-Indiana
    } \
    -body {
	clock format 1098466496 -format %H:%M:%S%z -timezone US/East-Indiana
    } \
    -cleanup {


	unset -nocomplain env(TZ)



    } \
    -result {12:34:56-0500}

test clock-44.2 {regression test - time zone containing only two digits} \
    -body {
	clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z
    } \

    -match regexp \
    -result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}}

test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \
    -constraints {win noappverifier} \
    -setup {
	# override the registry so that the test takes place in New York time

	::testClock::_setupRegistry











	# make it so New York time is a missing file
	dict set ::tcl::clock::WinZoneInfo \
	    {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} \
	    :No/Such/File
	::tcl::clock::ClearCaches
    } \
    -body {
	list [::tcl::clock::GuessWindowsTimeZone] \
	    [clock format 0 -locale system -format "%H:%M:%S %Z"] \
	    [clock format -86400 -format "%Y"]
    } \
    -cleanup {
	# restore the registry and environment

	::testClock::_cleanupRegistry








	# put New York back on the map
	dict set ::tcl::clock::WinZoneInfo \
	    {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} \
	    :America/New_York
	::tcl::clock::ClearCaches
    } \
    -result {<-0500>+05:00:00<-0400>+04:00:00,M3.2.0/02:00:00,M11.1.0/02:00:00 {19:00:00 -0500} 1969}

    unset ::tcltest::skippedBecause(valid_off)
}
if {!$valid_mode && [info exists ::tcltest::skippedBecause(!valid_off)]} {
    incr ::tcltest::numTests(Total) -$::tcltest::skippedBecause(!valid_off)
    incr ::tcltest::numTests(Skipped) -$::tcltest::skippedBecause(!valid_off)
    unset ::tcltest::skippedBecause(!valid_off)
}
::testClock::_cleanupNoTZ
namespace delete ::testClock
::tcltest::cleanupTests
unset valid_mode

return

# Local Variables:
# mode: tcl
# End:

    } -> foo] [dictSort $foo] [info errorstack]
} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}}
test cmdMZ-return-2.19 {return option handling} -body {
    return -level 0 -options {-options {-code break} -code continue}
} -returnCodes continue -result {}
test cmdMZ-return-2.20 {return option handling} {
    list [catch {
	return -level 0 -options {-foo 1} -options {-bar 2}
    } -> foo] $foo
} {0 {-foo 1 -bar 2 -code 0 -level 0}}
test cmdMZ-return-2.21 {return option handling} {
    list [catch {
	return -level 0 -options {-options {-foo 1} -options {-bar 2}}
    } -> foo] $foo
} {0 {-foo 1 -bar 2 -code 0 -level 0}}

	set d {p {q {a 1 b 2}}}
	apply {{} {
	    uplevel 1 {
		dict with d p q {
		    string cat "$a,$b"
		}
	    }
	}}
    }}
} 1,2

proc linenumber {} {
    dict get [info frame -1] line
}
test dict-23.1 {dict compilation crash: Bug 3487626} {

    encoding system iso8859-1
    llength shiftjis		;# Shimmer away any cache of Tcl_Encoding
    lappend x [catch {encoding convertto shiftjis 乎} msg] $msg
} -cleanup {
    encoding system iso8859-1
    encoding dirs $path
    encoding system $system
    unset -nocomplain path
} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}"

test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
    set old [encoding system]
} -body {
    encoding system shiftjis
    encoding system

} -cleanup {
    encoding dirs $path
    cd [workingDirectory]
    removeFile [file join tmp encoding junk2.enc]
    removeFile [file join tmp encoding junk.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    unset -nocomplain path
} -result {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
    set old [encoding system]
} -body {
    encoding system jis0208
    encoding convertto 乎

    set system [encoding system]
    set path [encoding dirs]
    encoding system iso8859-1
    encoding dirs {}
    llength jis0208	;# Shimmer any cached Tcl_Encoding in shared literal
    set x [list [catch {encoding convertto jis0208 乎} msg] $msg]
    encoding dirs $path
    unset -nocomplain path
    encoding system $system
    lappend x [encoding convertto jis0208 乎]
} {1 {unknown encoding "jis0208"} 8C}
test encoding-11.2 {LoadEncodingFile: single-byte} {
    encoding convertfrom jis0201 \xA1
} ｡
test encoding-11.3 {LoadEncodingFile: double-byte} {

} -returnCodes error -cleanup {
    file delete [file join [temporaryDirectory] tmp encoding splat.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    cd [workingDirectory]
    encoding dirs $path
    encoding system $system
    unset -nocomplain path
} -result {invalid encoding file "splat"}
test encoding-11.8 {encoding: extended Unicode UTF-16} {
    encoding convertto utf-16le 😹
} =Ø9Þ
test encoding-11.9 {encoding: extended Unicode UTF-16} {
    encoding convertto utf-16be 😹
} Ø=Þ9

    encoding convertfrom -profile replace iso2022-jp "\x1b\$B\$*;n\$"
} -result \u304A\u8A66\uFFFD

test encoding-bug-7346adc50f-tcl8 {OOM on convertfrom truncated iso2022 - tcl8} -body {
    encoding convertfrom -profile tcl8 iso2022-jp "\x1b\$B\$*;n\$"
} -result \u304A\u8A66\uFFFD

test encoding-dirs-bug-87b69745be {encoding dirs reset on interp creation} -setup {
    set origEncodingDirs [encoding dirs]
} -cleanup {
    encoding dirs $origEncodingDirs
    unset -nocomplain origEncodingDirs
} -body {
    encoding dirs [linsert [encoding dirs] end /temp]
    interp delete [interp create]
	encoding dirs
} -result [linsert [encoding dirs] end /temp]

# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:


# ----------------------------------------------------------------------
# cleanup

foreach file {gorp.file gorp.file2 echo echo2 echobin cat wc sh sh2 sleep exit err} {
    removeFile $file
}
unset -nocomplain path tmp

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -body {
    set r {}
    if {[info exists env(SystemDrive)]} {
	set path $env(SystemDrive)/pagefile.sys
	lappend r exists [file exists $path]
	lappend r readable [file readable $path]
	lappend r stat [catch {file stat $path a} e] $e
        unset -nocomplain path
    }
    return $r
} -result {exists 1 readable 0 stat 0 {}}

test fCmd-31.1 {file home} -body {
    file home
} -result [file join $::env(HOME)]
test fCmd-31.2 {file home - obeys env} -setup {
    set temp $::env(HOME)
    set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
    set ::env(HOME) $temp
    unset temp
} -body {
    file home
} -result [file join $::env(HOME) xxx]
test fCmd-31.3 {file home - \ -> /} -constraints win -setup {
    set temp $::env(HOME)
    set ::env(HOME) C:\\backslash\\path
} -cleanup {
    set ::env(HOME) $temp
    unset temp
} -body {
    file home
} -result C:/backslash/path
test fCmd-31.4 {file home - error} -setup {
    set saved $::env(HOME)
    unset ::env(HOME)
} -cleanup {
    set ::env(HOME) $saved
    unset saved
} -body {
    file home
} -returnCodes error -result {couldn't find HOME environment variable to expand path}
test fCmd-31.5 {
    file home - relative path. Following 8.x ~ expansion behavior, relative
    paths are not made absolute
} -setup {
    set saved $::env(HOME)
    set ::env(HOME) relative/path
} -cleanup {
    set ::env(HOME) $saved
    unset saved
} -body {
    file home
} -result relative/path
test fCmd-31.6 {file home USER} -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # env(HOME) even when user is current user. Assume result contains user
    # name, else not sure how to check
    string tolower [file home $::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-31.7 {file home UNKNOWNUSER} -body {
    file home nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-31.8 {file home extra arg} -body {
    file home $::tcl_platform(user) arg
} -returnCodes error -result {wrong # args: should be "file home ?user?"}
test fCmd-31.9 {file home USER does not follow env(HOME)} -setup {
    set saved $::env(HOME)
    set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
    set ::env(HOME) $saved
    unset saved
} -body {
    string tolower [file home $::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]

# file tildeexpand and testfstildexpand are identical in behavior
# but tested separately as the former is a script wrapper that does some
# sanitization/optimization while the latter is a raw call to Tcl_FSTildeExpand.
test fCmd-32.1 {file tildeexpand ~} -body {
    file tildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.1.1 {Tcl_FSTildeExpand ~} -constraints testfstildeexpand -body {
    testfstildeexpand ~
} -result [file join $::env(HOME)]
test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
    set saved $::env(HOME)
    set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
    set ::env(HOME) $saved
    unset saved
} -body {
    file tildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.2.1 {Tcl_FSTildeExpand ~ - obeys env} -setup {
    set saved $::env(HOME)
    set ::env(HOME) $::env(HOME)/xxx
} -cleanup {
    set ::env(HOME) $saved
    unset saved
} -constraints testfstildeexpand -body {
    testfstildeexpand ~
} -result [file join $::env(HOME) xxx]
test fCmd-32.3 {file tildeexpand ~ - error} -setup {
    set saved $::env(HOME)
    unset ::env(HOME)
} -cleanup {

test fCmd-32.16.1 {Tcl_FSTildeExpand ~USER\\bar} -constraints testfstildeexpand -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # env(HOME) even when user is current user. Assume result contains user
    # name, else not sure how to check
    string tolower [testfstildeexpand ~$::tcl_platform(user)\\bar]
} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
    set oldHome $::env(HOME)
    set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
    set ::env(HOME) $oldHome
} -body {
    string tolower [file tildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]
test fCmd-32.17.1 {Tcl_FSTildeExpand ~USER does not mirror HOME} -setup {
    set oldHome $::env(HOME)
    set ::env(HOME) [file join $::env(HOME) foo]
} -cleanup {
    set ::env(HOME) $oldHome
} -constraints testfstildeexpand -body {
    string tolower [testfstildeexpand ~$::tcl_platform(user)]
} -match glob -result [gethomedirglob $::tcl_platform(user)]


# cleanup
cleanup

# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}
set existingGlobals [info globals]

::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
source [file join [file dirname [info script]] tcltests.tcl]

testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]

} -result {}
test filename-14.22 {asterisks, question marks, and brackets} -body {
    glob goo/* x*z foo?q
} -result {}
test filename-14.23 {slash globbing} {unix} {
    glob /
} /

# NOTE: [The string index x/ 1] construction is a workaround for the
# testsetplatform calls above interacting with normalized path caching
# in -singleproc 1 runs. See ticket [8c63606802].
test filename-14.23.2 {slash globbing} {win} {
    glob /
} [file normalize [string index x/ 1]]
test filename-14.24 {slash globbing} {win} {
    glob {\\}
} [file normalize [string index x/ 1]]

test filename-14.25 {type specific globbing} {unix} {
    lsort [glob -dir globTest -types f *]
} [lsort [list \
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
	[file join $globname x1.c]\
	[file join $globname y1.c] [file join $globname z1.c]]]

cd $oldpwd
catch {removeDirectory tcl[pid]}
set env(HOME) $oldhome
if {[testConstraint testsetplatform]} {
    testsetplatform $platform
    catch {unset platform}
}
unset -nocomplain {*}[lmap x [info globals] {
    if {$x in $existingGlobals} {continue}
    set x
}]

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

    set dir [pwd]
} -constraints {win moreThanOneDrive notInCIenv} -body {
    set path "[string range [lindex $drives 0] 0 1]foo"
    cd [lindex $drives 1]
    file norm $path
} -cleanup {
    cd $dir
    unset -nocomplain path
} -result "[lindex $drives 0]foo"
test filesystem-1.39 {file normalisation with volume relative} -setup {
    set old [pwd]
} -constraints {win} -body {
    set drv C:/
    cd [lindex [glob -type d -dir $drv *] 0]
    file norm [string range $drv 0 1]

	foreach initial $initials {
	    lappend x [info object class $initial]
	}
	return $x
    }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::SingletonInstance ::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::SingletonInstance ::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup {
    oo::class create parent
} -body {
    oo::class create abc {
	superclass parent
	variable n
	constructor {} {set n 0}

	lappend ::result {*}$args
    }
    set result {}
} -body {
    trace add execution oo::define::initialise enter appendToResultVar
    oo::class create ::cls {
	superclass parent
	initialise {proc xyzzy {} {}}
    }
    return $result
} -cleanup {
    catch {
	trace remove execution oo::define::initialise enter appendToResultVar
    }
    rename ::appendToResultVar {}
    parent destroy
} -result {{initialise {proc xyzzy {} {}}} enter}







test ooUtil-4.1 {TIP 478: singleton} -setup {
    oo::class create parent
} -body {
    oo::singleton create xyz {
	superclass parent
    }

test platform-1.0 {tcl_platform(engine)} {
  set tcl_platform(engine)
} {Tcl}

test platform-1.1 {TclpSetVariables: tcl_platform} {
    interp create i


    set result [i eval {lsort [array names tcl_platform]}]
    interp delete i
    set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}

test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize {
    expr {$tcl_platform(wordSize) == [testlongsize]}

    # "still reachable" reports.
    platform::identify
} -result {^([^-]+-)+[^-]+$}
test platform-4.2 {format of platform::generic result} -match regexp -body {
    platform::generic
} -result {^([^-]+-)+[^-]+$}

test platform-5.0 {format of platform::generic result} -setup {
    set old_machine $::tcl_platform(machine)
    set old_os $::tcl_platform(os)
    set old_wordsize $::tcl_platform(wordSize)
    set old_version $tcl_platform(osVersion)
    set ::tcl_platform(machine) arm
    set ::tcl_platform(os) Darwin
    set ::tcl_platform(wordSize) 8
} -body {
    set res {}
    set l {macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl}
    foreach v {20.0 21.0 22.0 23.0 24.0 25.0 26.0} {
	set ::tcl_platform(osVersion) $v
	set id [platform::identify]
	set l [linsert $l 0 [string range $id 0 end-4]-x86_64]
	set l [linsert $l 0 $id]
	lappend res $id
	lappend res [expr {($l eq [platform::patterns $id]) ? 1 : [platform::patterns $id]}]
    }
    set res
} -cleanup {
    set ::tcl_platform(machine) $old_machine
    set ::tcl_platform(os) $old_os
    set ::tcl_platform(wordSize) $old_wordsize
    set ::tcl_platform(osVersion) $old_version
    unset res l old_machine old_os old_wordsize old_version
} -result {macos11-arm 1 macos12-arm 1 macos13-arm 1 macos14-arm 1 macos15-arm 1 macos26-arm 1 macos27-arm 1}
test platform-5.1 {format of platform::patterns macos26-x86_64} -body {
    platform::patterns macos26-x86_64
} -result {macos26-x86_64 macos15-x86_64 macos14-x86_64 macos13-x86_64 macos12-x86_64 macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl}
test platform-5.2 {format of platform::patterns macos26-arm} -body {
    platform::patterns macos26-arm
} -result {macos26-arm macos26-x86_64 macos15-arm macos15-x86_64 macos14-arm macos14-x86_64 macos13-arm macos13-x86_64 macos12-arm macos12-x86_64 macos11-arm macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl}

# cleanup
cleanupTests

}
namespace delete ::tcl::test::platform
return

# Local Variables:
# mode: tcl
# End:

    namespace import -force ::tcltest::*
}

testConstraint reg 0
if {[testConstraint win]} {
    if {![catch {
	    ::tcltest::loadTestedCommands
	    set ::regver [package require registry 1.4a1]
	}]} {
	testConstraint reg 1
    }
}
testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]

# determine the current locale
testConstraint english [expr {
    [llength [info commands testlocale]]
    && [string match "English*" [testlocale all ""]]
}]

test registry-1.0 {check if we are testing the right dll} {win reg} {
    set ::regver
} {1.4a1}
test registry-1.1 {argument parsing for registry command} {win reg} {
    list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
    list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {

    rename foo {}
} -result {5 0}
test tailcall-15.3 {tailcall memory leak check} -constraints memory -setup {
    proc foo {args} {llength $args}
} -body {
    list [
	apply {args {
	    tailcall foo 1 2 {*}$args 3 4 {*}$args 5
	}} a b c
    ] [
	leaktest {
	    apply {args {
		tailcall foo 1 2 {*}$args 3 4 {*}$args 5
	    }} a b c
	}
    ]
} -cleanup {
    rename foo {}
} -result {11 0}

    set env(LANG) japanese
    set env(LC_ALL) japanese
    set f [open "|[list [interpreter]]" w+]
    chan configure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    set enc






} -cleanup {
    unset -nocomplain env(LANG) env(LC_ALL)
    catch {set env(LC_ALL) $oldlc_all}
    catch {set env(TCL_LIBRARY) $oldtcl_library}
} -result {^(euc-jp|shiftjis)$} -match regexp

test unixInit-4.1 {TclpSetVariables} {unix} {
    # just make sure they exist
    set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
    set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
    set tcl_platform(platform)
} "unix"

    gets $f line
    return $f
}

# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
    set ::ddever
} {1.5a1}

test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
    list [dde servername foobar] [dde servername] [dde servername self]
} -result {foobar foobar self}

test winDde-2.1 {Checking for other services} -constraints dde -body {
    expr {[llength [dde services {} {}]] >= 0}

# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

::namespace eval ::oo {
























































































































































































































































































































































    # ----------------------------------------------------------------------
    #
    # oo::object <cloned> --
    #
    #	Handler for cloning objects that clones basic bits (only!) of the
    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
    #	more complex (and class-specific) handling.

    # oo::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> -unexport {originObject} {
	set targetObject [self]
	next $originObject
	# Rebuild the class inheritance delegation class
	set originDelegate [::oo::DelegateName $originObject]
	set targetDelegate [::oo::DelegateName $targetObject]
	if {
	    [info object isa class $originDelegate]
	    && ![info object isa class $targetDelegate]
	} then {
	    ::oo::copy $originDelegate $targetDelegate
	    ::oo::objdefine $targetObject mixin -set \
		{*}[lmap c [info object mixin $targetObject] {
		    if {$c eq $originDelegate} {set targetDelegate} {set c}
		}]
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::singleton --
    #
    #	A metaclass that is used to make classes that only permit one instance
    #	of them to exist. See singleton(n).
    #
    # ----------------------------------------------------------------------

    class create singleton
    define singleton superclass -set class

    define singleton unexport create createWithNamespace
    define singleton method new args {
	variable object
	if {![info exists object] || ![info object isa object $object]} {
	    set object [next {*}$args]
	    ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance
	}
	return $object
    }

    # ----------------------------------------------------------------------
    #
    # oo::SingletonInstance --
    #
    #	A mixin used to make an object so it won't be destroyed or cloned (or
    #	at least not easily).
    #
    # ----------------------------------------------------------------------

    class create SingletonInstance
    define SingletonInstance method destroy {} {
	return -code error -errorcode {TCL OO SINGLETON} \
	    "may not destroy a singleton object"
    }
    define SingletonInstance method <cloned> -unexport {originObject} {
	return -code error -errorcode {TCL OO SINGLETON} \
	    "may not clone a singleton object"





    }

    # ----------------------------------------------------------------------
    #
    # oo::abstract --
    #
    #	A metaclass that is used to make classes that can't be directly
    #	instantiated. See abstract(n).
    #
    # ----------------------------------------------------------------------

    class create abstract
    define abstract superclass -set class
    define abstract unexport create createWithNamespace new


    # ----------------------------------------------------------------------
    #
    # oo::configuresupport --
    #
    #	Namespace that holds all the implementation details of TIP #558.
    #	Also includes the commands:

    #	These cause very fast basic implementation methods for a property
    #	following the standard model of property implementation naming.
    #	Property schemes that use other models (such as to be more Tk-like)
    #	should not use these (or the oo::cconfigurable metaclass).
    #
    # ----------------------------------------------------------------------


    # ------------------------------------------------------------------
    #
    # oo::configuresupport::configurableclass,
    # oo::configuresupport::configurableobject --
    #
    #	Namespaces used as implementation vectors for oo::define and
    #	oo::objdefine when the class/instance is configurable.
    #	Note that these also contain commands implemented in C,
    #	especially the [property] definition command.
    #
    # ------------------------------------------------------------------

    namespace eval configuresupport::configurableclass {
	# Plural alias just in case; deliberately NOT documented!
	::proc properties args {::tailcall property {*}$args}
	::namespace path ::oo::define
	::namespace export property
    }

    namespace eval configuresupport::configurableobject {
	# Plural alias just in case; deliberately NOT documented!
	::proc properties args {::tailcall property {*}$args}
	::namespace path ::oo::objdefine
	::namespace export property
    }

    # ------------------------------------------------------------------
    #
    # oo::configuresupport::configurable --
    #
    #	The class that contains the implementation of the actual
    #	'configure' method (mixed into actually configurable classes).
    #	The 'configure' method is in tclOOBasic.c.
    #
    # ------------------------------------------------------------------

    define configuresupport::configurable {
	definitionnamespace -instance configuresupport::configurableobject
	definitionnamespace -class configuresupport::configurableclass

    }

    # ----------------------------------------------------------------------
    #
    # oo::configurable --
    #
    #	A metaclass that is used to make classes that can be configured in
    #	their creation phase (and later too). All the metaclass itself does is
    #	arrange for the class created to have a 'configure' method and for
    #	oo::define and oo::objdefine (on the class and its instances) to have
    #	a property definition for setting things up for 'configure'.
    #
    # ----------------------------------------------------------------------

    class create configurable
    define configurable superclass -set class

    define configurable constructor {{definitionScript ""}} {
	::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
	next $definitionScript
    }

    define configurable definitionnamespace -class configuresupport::configurableclass

}

# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:

# around; better to use the install-sh script that comes with the
# distribution, which is slower but guaranteed to work.

INSTALL_STRIP_PROGRAM	= strip
INSTALL_STRIP_LIBRARY	= strip -x

INSTALL			= $(SHELL) $(UNIX_DIR)/install-sh -c
INSTALL_PROGRAM		= ${INSTALL} -m 755
INSTALL_LIBRARY		= ${INSTALL} -m 755
INSTALL_DATA		= ${INSTALL} -m 644
INSTALL_DATA_DIR	= ${INSTALL} -d -m 755

# NATIVE_TCLSH is the name of a tclsh executable that is available *BEFORE*
# running make for the first time. Certain build targets (make genstubs) need
# it to be available on the PATH. This executable should *NOT* be required
# just to do a normal build although it can be required to run make dist.

	    if [ ! -d "$$i" ] ; then \
		echo "Making directory $$i"; \
		$(INSTALL_DATA_DIR) "$$i"; \
	    fi; \
	done
	@echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/"
	@@INSTALL_LIB@

	@echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
	@$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)${EXE_SUFFIX}"
	@echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh"
	@echo "Installing tclooConfig.sh to $(CONFIG_INSTALL_DIR)/"
	@$(INSTALL_DATA) $(UNIX_DIR)/tclooConfig.sh \
		"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"

	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"
	@for i in $(TOP_DIR)/library/opt/*.tcl; do \
	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	done
	@echo "Installing package msgcat 1.7.1 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
		"$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm"
	@echo "Installing package tcltest 2.5.10 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
		"$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.10.tm"
	@echo "Installing package platform 1.1.0 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
		"$(MODULE_INSTALL_DIR)/9.0/platform-1.1.0.tm"
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
		"$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm"
	@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
	@for i in $(TOP_DIR)/library/encoding/*.enc; do \
		$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done

TCL_VERSION=9.1
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=1
TCL_PATCH_LEVEL="a1"
VERSION=${TCL_VERSION}

EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}

#------------------------------------------------------------------------
# Setup configure arguments for bundled packages

    /* override */ #undef PACKAGE_STRING
    #endif /* _TCLCONFIG */])
])

TCL_VERSION=9.1
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=1
TCL_PATCH_LEVEL="a1"
VERSION=${TCL_VERSION}

EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}

#------------------------------------------------------------------------
# Setup configure arguments for bundled packages

DLLEXPORT int
Pkgt_Init(
    Tcl_Interp *interp)		/* Interpreter in which the package is to be
				 * made available. */
{
    int code;

    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    code = Tcl_PkgProvide(interp, "pkgt", "1.0");
    if (code != TCL_OK) {
	return code;
    }
    Tcl_CreateObjCommand2(interp, "pkgt_eq", Pkgt_EqObjCmd2, NULL, NULL);

# This file is the basis for a binary Tcl RPM for Linux.

%{!?directory:%define directory /usr/local}

Name:          tcl
Summary:       Tcl scripting language development environment
Version:       9.1a1
Release:       2
License:       BSD
Group:         Development/Languages
Source:        https://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
URL:           https://www.tcl-lang.org/
Buildroot:     /var/tmp/%{name}%{version}

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tcl.h"
#if TCL_MAJOR_VERSION < 9
#   if defined(USE_TCL_STUBS)
#	error "Don't build with USE_TCL_STUBS!"
#   endif

#   define Tcl_LibraryInitProc Tcl_PackageInitProc
#   define Tcl_StaticLibrary Tcl_StaticPackage

#endif

#ifdef TCL_TEST
#ifdef __cplusplus
extern "C" {
#endif
extern Tcl_LibraryInitProc Tcltest_Init;

{
#ifdef TCL_XT_TEST
    XtToolkitInitialize();
#endif

#ifdef TCL_LOCAL_MAIN_HOOK
    TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif TCL_MAJOR_VERSION > 8 && (!defined(_WIN32) || defined(UNICODE))
    /* New in Tcl 9.0. This doesn't work on Windows without UNICODE */
    TclZipfs_AppHook(&argc, &argv);
#endif

    Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
    return 0;			/* Needed only to prevent compiler warning. */
}


DDE_LIB_FILE		= @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX}
REG_DLL_FILE		= tcl9registry$(REGVER)${DLLSUFFIX}
REG_LIB_FILE		= @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
TEST_DLL_FILE		= tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE		= tcltest${EXESUFFIX}
TEST_LIB_FILE		= @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX}
TEST_LOAD_PRMS		= lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
			  package ifneeded dde 1.5a1 [list load ${DDE_DLL_FILE}];\
			  package ifneeded registry 1.4a1 [list load ${REG_DLL_FILE}]
TEST_LOAD_FACILITIES	= package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\
			  $(TEST_LOAD_PRMS)
ZLIB_DLL_FILE		= zlib1.dll
TOMMATH_DLL_FILE	= libtommath.dll

SHARED_LIBRARIES	= $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES	= $(TCL_LIB_FILE)

%.${OBJEXT}: %.c
	$(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME)

.rc.$(RES):
	$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@

tclOO.${OBJEXT}: tclOO.c tclOOScript.h

#--------------------------------------------------------------------------
# Minizip implementation
#--------------------------------------------------------------------------
adler32.$(HOST_OBJEXT):
	$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/adler32.c

	@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/9.0/http-2.10.0.tm";
	@echo "Installing package opt 0.4.7";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing package msgcat 1.7.1 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/9.0/msgcat-1.7.1.tm";
	@echo "Installing package tcltest 2.5.10 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/9.0/tcltest-2.5.10.tm";
	@echo "Installing package platform 1.1.0 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/9.0/platform-1.1.0.tm";
	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
	@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/9.0/platform/shell-1.1.4.tm";
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=9.1
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=1
TCL_PATCH_LEVEL="a1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.5
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=5
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION

# versions of autoconf incorrectly set SHELL to /bin/bash instead of
# /bin/sh. The bash shell seems to suffer from some strange failures.
SHELL=/bin/sh

TCL_VERSION=9.1
TCL_MAJOR_VERSION=9
TCL_MINOR_VERSION=1
TCL_PATCH_LEVEL="a1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.5
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=5
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION