Tcl Source Code

Check-in [8cdb898408]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge core-8-branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-431
Files: files | file ages | folders
SHA3-256: 8cdb8984084595d70b401e7419a2b5418f88f9ca4621ed9232ec79d124524aa0
User & Date: dkf 2019-05-17 07:31:47
Context
2019-05-17
08:09
Add test for what happens when the directory in the template doesn't exist; doc it too. check-in: 92fce1400e user: dkf tags: tip-431
07:31
merge core-8-branch check-in: 8cdb898408 user: dkf tags: tip-431
2019-05-14
19:26
Merge 8.6 check-in: 2c56cc8106 user: jan.nijtmans tags: core-8-branch
2019-05-13
17:56
Fix new tests cmdAH-33.[45] by making them pass on Windows check-in: 4493d19929 user: fvogel tags: tip-431
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/TraceVar.3.

327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
The return value from \fIproc\fR is only used during read and
write tracing.
During unset traces, the return value is ignored and all relevant
trace procedures will always be invoked.
.SH "RESTRICTIONS"
.PP
A trace procedure can be called at any time, even when there
is a partially formed result in the interpreter's result area.  If
the trace procedure does anything that could damage this result (such
as calling \fBTcl_Eval\fR) then it must save the original values of
the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore
them before it returns.
.SH "UNDEFINED VARIABLES"
.PP
It is legal to set a trace on an undefined variable.
The variable will still appear to be undefined until the
first time its value is set.
If an undefined variable is traced and then unset, the unset will fail
with an error






|

|
|
|







327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
The return value from \fIproc\fR is only used during read and
write tracing.
During unset traces, the return value is ignored and all relevant
trace procedures will always be invoked.
.SH "RESTRICTIONS"
.PP
A trace procedure can be called at any time, even when there
are partially formed results stored in the interpreter.  If
the trace procedure does anything that could damage this result (such
as calling \fBTcl_Eval\fR) then it must use the \fBTcl_SaveInterpState\fR
and related routines to save and restore the original state of
the interpreter before it returns.
.SH "UNDEFINED VARIABLES"
.PP
It is legal to set a trace on an undefined variable.
The variable will still appear to be undefined until the
first time its value is set.
If an undefined variable is traced and then unset, the unset will fail
with an error

Changes to generic/tclBasic.c.

169
170
171
172
173
174
175

176
177
178
179
180
181
182
...
970
971
972
973
974
975
976

977
978


979
980
981
982
983
984
985
....
2374
2375
2376
2377
2378
2379
2380

2381


2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
....
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
....
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
....
4603
4604
4605
4606
4607
4608
4609

4610


4611

4612


4613
4614
4615
4616
4617
4618

4619
4620
4621
4622
4623
4624
4625
....
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639

4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
....
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
....
4758
4759
4760
4761
4762
4763
4764

4765

4766
4767
4768
4769

4770
4771
4772
4773
4774
4775
4776
....
6970
6971
6972
6973
6974
6975
6976

6977


6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
....
8371
8372
8373
8374
8375
8376
8377


8378


8379
8380
8381
8382
8383


8384


8385
8386
8387
8388
8389
8390
8391
....
8731
8732
8733
8734
8735
8736
8737

8738
8739

8740
8741
8742
8743
8744
8745
8746
....
9183
9184
9185
9186
9187
9188
9189





































































9190
9191
9192
9193
9194
9195
9196
....
9413
9414
9415
9416
9417
9418
9419

9420


9421
9422
9423
9424
9425
9426
9427
9428
9429
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;


MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;


    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);



    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
	    /*
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}


	/* An existing command conflicts. Try to delete it.. */


	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Be careful to preserve
	 * any existing import links so we can restore them down below. That
	 * way, you can redefine a command and its import status will remain
	 * intact.
	 */

	cmdPtr->refCount++;
	if (cmdPtr->importRefPtr) {
	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
	}

................................................................................
	}
	TclCleanupCommandMacro(cmdPtr);
	deleted = 1;
    }

    if (!isNew) {
	/*
	 * If the deletion callback recreated the command, just throw away
	 * the new command (if we try to delete it again, we could get
	 * stuck in an infinite loop).
	 */

	ckfree(Tcl_GetHashValue(hPtr));
    }

    if (!deleted) {

	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
................................................................................
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it.
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy
	 * behavior is kept under particular circumstances to accommodate
	 * deployed binaries of the "tclcompiler" program
	 *     http://sourceforge.net/projects/tclpro/
         * that crash if the bug is fixed.
	 */

	if (cmdPtr->objProc == TclInvokeStringCommand
		&& cmdPtr->clientData == clientData
		&& cmdPtr->deleteData == clientData
		&& cmdPtr->deleteProc == deleteProc) {
	    cmdPtr->objProc = proc;
................................................................................
    /*
     * Lookup the Command to dispatch.
     */

    reresolve:
    assert(cmdPtr == NULL);
    if (preCmdPtr) {

	/* Caller gave it to us */


	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {

	    /* So long as it exists, use it. */


	    cmdPtr = preCmdPtr;
	} else if (flags & TCL_EVAL_NORESOLVE) {
	    /*
	     * When it's been deleted, and we're told not to attempt
	     * resolving it ourselves, all we can do is raise an error.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to invoke a deleted command"));
	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
	    return TCL_ERROR;
	}
    }
    if (cmdPtr == NULL) {
................................................................................
	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
    }

    if (enterTracesDone || iPtr->tracePtr
	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {

	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv);
	Tcl_IncrRefCount(commandPtr);


	if (!enterTracesDone) {

	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
		    objc, objv);

	    /*
	     * Send any exception from enter traces back as an exception
	     * raised by the traced command.
	     * TODO: Is this a bug?  Letting an execution trace BREAK or
	     * CONTINUE or RETURN in the place of the traced command?
	     * Would either converting all exceptions to TCL_ERROR, or
	     * just swallowing them be better?  (Swallowing them has the
	     * problem of permanently hiding program errors.)
	     */

	    if (code != TCL_OK) {
		Tcl_DecrRefCount(commandPtr);
		return code;
	    }

	    /*
	     * If the enter traces made the resolved cmdPtr unusable, go
	     * back and resolve again, but next time don't run enter
	     * traces again.
	     */

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/*
	 * Schedule leave traces.  Raise the refCount on the resolved
	 * cmdPtr, so that when it passes to the leave traces we know
	 * it's still valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
		    commandPtr, cmdPtr, objv);
    }

................................................................................
    struct NRE_callback *rootPtr)
				/* All callbacks down to rootPtr not inclusive
				 * are to be run. */
{
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    Interp *iPtr = (Interp *) interp;
#endif /* !defined(TCL_NO_DEPRECATED) */
    NRE_callback *callbackPtr;
    Tcl_NRPostProc *procPtr;

    /*
     * If the interpreter has a non-empty string result, the result object is
     * either empty or stale because some function set interp->result
     * directly. If so, move the string result to the result object, then
     * reset the string result.
     *
................................................................................

#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }
#endif /* !defined(TCL_NO_DEPRECATED) */


    /* This is the trampoline. */


    while (TOP_CB(interp) != rootPtr) {
	callbackPtr = TOP_CB(interp);
	procPtr = callbackPtr->procPtr;

	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);
    }
    return result;
}

................................................................................
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);


    /* Avoid the exception-handling brain damage when numLevels == 0 . */


    iPtr->numLevels++;
    Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);

    /*
     * Normal command resolution of objv[0] isn't going to find cmdPtr.
     * That's the whole point of **hidden** commands.  So tell the
     * Eval core machinery not to even try (and risk finding something wrong).
     */

    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}

static int
NRPostInvoke(
................................................................................
	kini("line");	kini("level");
#undef kini
    }
    for (i = 0; i < 6; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
	args[i] = val ? TclGetString(val) : NULL;
    }


    /* no "proc" -> use "lambda" */


    if (!args[2]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[2] = val ? TclGetString(val) : NULL;
    }
    k++;


    /* no "class" -> use "object" */


    if (!args[5]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[5] = val ? TclGetString(val) : NULL;
    }
    k++;
    for (i = 0; i < 2; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
................................................................................
     * at the proper time.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;


        /* The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled. */


        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *





































































 * NRCoroInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

................................................................................
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);


    /* ensure that the command is looked up in the correct namespace */


    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
    iPtr->numLevels--;

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;

    /*






>







 







>


>
>







 







>
|
>
>



|
|
|
<







 







|
|
|






<







 







|





|
|
|
|
|







 







>
|
>
>

>
|
>
>



|
|

>







 







<



<

>

<







|
|
|
|








|
|
<










|
|
|







 







<
<







 







>
|
>


|
|
>







 







>
|
>
>





|
|







 







>
>
|
>
>





>
>
|
>
>







 







>
|
|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
|
>
>

|







169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
....
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394

2395
2396
2397
2398
2399
2400
2401
....
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422

2423
2424
2425
2426
2427
2428
2429
....
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
....
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
....
4639
4640
4641
4642
4643
4644
4645

4646
4647
4648

4649
4650
4651

4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672

4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
....
4748
4749
4750
4751
4752
4753
4754


4755
4756
4757
4758
4759
4760
4761
....
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
....
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
....
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
....
8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
....
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
....
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514
9515
9516
9517
9518
9519
9520
9521
9522
9523
9524
static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
            CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
	    /*
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it...
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Be careful to preserve any existing import links so we can restore
	 * them down below. That way, you can redefine a command and its
	 * import status will remain intact.

	 */

	cmdPtr->refCount++;
	if (cmdPtr->importRefPtr) {
	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
	}

................................................................................
	}
	TclCleanupCommandMacro(cmdPtr);
	deleted = 1;
    }

    if (!isNew) {
	/*
	 * If the deletion callback recreated the command, just throw away the
	 * new command (if we try to delete it again, we could get stuck in an
	 * infinite loop).
	 */

	ckfree(Tcl_GetHashValue(hPtr));
    }

    if (!deleted) {

	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
................................................................................
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it...
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * [***] This is wrong.  See Tcl Bug a16752c252.
	 * However, this buggy behavior is kept under particular circumstances
	 * to accommodate deployed binaries of the "tclcompiler" program
	 * <http://sourceforge.net/projects/tclpro/> that crash if the bug is
	 * fixed.
	 */

	if (cmdPtr->objProc == TclInvokeStringCommand
		&& cmdPtr->clientData == clientData
		&& cmdPtr->deleteData == clientData
		&& cmdPtr->deleteProc == deleteProc) {
	    cmdPtr->objProc = proc;
................................................................................
    /*
     * Lookup the Command to dispatch.
     */

    reresolve:
    assert(cmdPtr == NULL);
    if (preCmdPtr) {
	/*
         * Caller gave it to us.
         */

	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
	    /*
             * So long as it exists, use it.
             */

	    cmdPtr = preCmdPtr;
	} else if (flags & TCL_EVAL_NORESOLVE) {
	    /*
	     * When it's been deleted, and we're told not to attempt resolving
	     * it ourselves, all we can do is raise an error.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to invoke a deleted command"));
	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
	    return TCL_ERROR;
	}
    }
    if (cmdPtr == NULL) {
................................................................................
	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
    }

    if (enterTracesDone || iPtr->tracePtr
	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {

	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv);


	Tcl_IncrRefCount(commandPtr);
	if (!enterTracesDone) {

	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
		    objc, objv);

	    /*
	     * Send any exception from enter traces back as an exception
	     * raised by the traced command.
	     * TODO: Is this a bug?  Letting an execution trace BREAK or
	     * CONTINUE or RETURN in the place of the traced command?  Would
	     * either converting all exceptions to TCL_ERROR, or just
	     * swallowing them be better?  (Swallowing them has the problem of
	     * permanently hiding program errors.)
	     */

	    if (code != TCL_OK) {
		Tcl_DecrRefCount(commandPtr);
		return code;
	    }

	    /*
	     * If the enter traces made the resolved cmdPtr unusable, go back
	     * and resolve again, but next time don't run enter traces again.

	     */

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/*
	 * Schedule leave traces.  Raise the refCount on the resolved cmdPtr,
	 * so that when it passes to the leave traces we know it's still
	 * valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
		    commandPtr, cmdPtr, objv);
    }

................................................................................
    struct NRE_callback *rootPtr)
				/* All callbacks down to rootPtr not inclusive
				 * are to be run. */
{
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    Interp *iPtr = (Interp *) interp;
#endif /* !defined(TCL_NO_DEPRECATED) */



    /*
     * If the interpreter has a non-empty string result, the result object is
     * either empty or stale because some function set interp->result
     * directly. If so, move the string result to the result object, then
     * reset the string result.
     *
................................................................................

#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
    if (*(iPtr->result) != 0) {
	(void) Tcl_GetObjResult(interp);
    }
#endif /* !defined(TCL_NO_DEPRECATED) */

    /*
     * This is the trampoline.
     */

    while (TOP_CB(interp) != rootPtr) {
        NRE_callback *callbackPtr = TOP_CB(interp);
        Tcl_NRPostProc *procPtr = callbackPtr->procPtr;

	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);
    }
    return result;
}

................................................................................
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);

    /*
     * Avoid the exception-handling brain damage when numLevels == 0
     */

    iPtr->numLevels++;
    Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);

    /*
     * Normal command resolution of objv[0] isn't going to find cmdPtr.
     * That's the whole point of **hidden** commands.  So tell the Eval core
     * machinery not to even try (and risk finding something wrong).
     */

    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}

static int
NRPostInvoke(
................................................................................
	kini("line");	kini("level");
#undef kini
    }
    for (i = 0; i < 6; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
	args[i] = val ? TclGetString(val) : NULL;
    }

    /*
     * no "proc" -> use "lambda"
     */

    if (!args[2]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[2] = val ? TclGetString(val) : NULL;
    }
    k++;

    /*
     * no "class" -> use "object"
     */

    if (!args[5]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[5] = val ? TclGetString(val) : NULL;
    }
    k++;
    for (i = 0; i < 2; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
................................................................................
     * at the proper time.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;

        /*
         * The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled.
         */

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * CoroTypeObjCmd --
 *
 *      Implementation of [::tcl::unsupported::corotype] command.
 *
 *----------------------------------------------------------------------
 */

static int
CoroTypeObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;

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

    /*
     * Look up the coroutine.
     */

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only get coroutine type of a coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);
        return TCL_ERROR;
    }

    /*
     * An active coroutine is "active". Can't tell what it might do in the
     * future.
     */

    corPtr = cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
        return TCL_OK;
    }

    /*
     * Inactive coroutines are classified by the (effective) command used to
     * suspend them, which matters when you're injecting a probe.
     */

    switch (corPtr->nargs) {
    case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
        return TCL_OK;
    case COROUTINE_ARGUMENTS_ARBITRARY:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
        return TCL_OK;
    default:
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unknown coroutine type", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
        return TCL_ERROR;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * NRCoroInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

................................................................................
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);

    /*
     * Ensure that the command is looked up in the correct namespace.
     */

    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
    iPtr->numLevels--;

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;

    /*

Changes to generic/tclBinary.c.

767
768
769
770
771
772
773

774


775
776
777
778
779
780
781
	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len < 0) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {

	/* Append zero bytes is a no-op. */


	return;
    }

    length = (unsigned int)len;

    irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {






>
|
>
>







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len < 0) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {
	/*
	 * Append zero bytes is a no-op.
	 */

	return;
    }

    length = (unsigned int)len;

    irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {

Changes to generic/tclCmdIL.c.

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
....
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
....
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
....
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
....
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
....
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
....
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
....
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
....
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
....
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
....
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
....
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
/*
 * The "lsort" command needs to pass certain information down to the function
 * that compares two list elements, and the comparison function needs to pass
 * success or failure information back up to the top-level "lsort" command.
 * The following structure is used to pass this information.
 */

typedef struct SortInfo {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below. */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Pre-initialized to hold
				 * base of command. */
    int *indexv;		/* If the -index option was specified, this
................................................................................
     * bytecompiled - in that case, the return was a copy of the body's string
     * rep. In order to better isolate the implementation details of the
     * compiler/engine subsystem, we now always return a copy of the string
     * rep. It is important to return a copy so that later manipulations of
     * the object do not invalidate the internal rep.
     */

    bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    if ((objc != 1) && (objc != 2)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
	return TCL_ERROR;
    }

    target = interp;
    if (objc == 2) {
	target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    iPtr = (Interp *) target;
    Tcl_SetObjResult(interp, iPtr->errorStack);
................................................................................
{
    Tcl_Command command;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "commandName");
	return TCL_ERROR;
    }
    command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
	    TCL_LEAVE_ERR_MSG);
    if (command == NULL) {
	return TCL_ERROR;
    }

    /*
     * There's one special case: safe slave interpreters can't see aliases as
................................................................................
	Tcl_SetObjResult(interp, elemPtrs[0]);
	return TCL_OK;
    }

    joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
    Tcl_IncrRefCount(joinObjPtr);

    (void) Tcl_GetStringFromObj(joinObjPtr, &length);
    if (length == 0) {
	resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
    } else {
	int i;

	resObjPtr = Tcl_NewObj();
	for (i = 0;  i < listLen;  i++) {
................................................................................
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

typedef int list_index_t;

static int
LremoveIndexCompare(
    const void *el1Ptr,
    const void *el2Ptr)
{
    list_index_t idx1 = *((const list_index_t *) el1Ptr);
    list_index_t idx2 = *((const list_index_t *) el2Ptr);

    /*
     * This will put the larger element first.
     */

    return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
................................................................................
Tcl_LremoveObjCmd(
    ClientData notUsed,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, idxc;
    list_index_t listLen, *idxv, prevIdx, first, num;
    Tcl_Obj *listObj;

    /*
     * Parse the arguments.
     */

    if (objc < 2) {
................................................................................
    }

    idxc = objc - 2;
    if (idxc == 0) {
	Tcl_SetObjResult(interp, listObj);
	return TCL_OK;
    }
    idxv = ckalloc((objc - 2) * sizeof(list_index_t));
    for (i = 2; i < objc; i++) {
	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
		&idxv[i - 2]) != TCL_OK) {
	    ckfree(idxv);
	    return TCL_ERROR;
	}
    }
................................................................................

    /*
     * Sort the indices, large to small so that when we remove an index we
     * don't change the indices still to be processed.
     */

    if (idxc > 1) {
	qsort(idxv, idxc, sizeof(list_index_t), LremoveIndexCompare);
    }

    /*
     * Make our working copy, then do the actual removes piecemeal.
     */

    if (Tcl_IsShared(listObj)) {
	listObj = TclListObjCopy(NULL, listObj);
    }
    num = 0;
    first = listLen;
    for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
	list_index_t idx = idxv[i];

	/*
	 * Repeated index and sanity check.
	 */

	if (idx == prevIdx) {
	    continue;
................................................................................
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first < 0) {
	first = 0;
    }
    if (first > listLen) {
	first = listLen;
    }

    if (last >= listLen) {
................................................................................

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		int encoded = 0;
		if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
			TCL_INDEX_NONE, &encoded) != TCL_OK) {
		    result = TCL_ERROR;
		}
		if (encoded == TCL_INDEX_NONE) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", Tcl_GetString(indices[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
................................................................................
     */

    if (startPtr) {
	result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
	if (result != TCL_OK) {
	    goto done;
	}
	if (start < 0) {
	    start = 0;
	}

	/*
	 * If the search started past the end of the list, we just return a
	 * "did not match anything at all" result straight away. [Bug 1374778]
	 */

................................................................................
	     */

	    for (j=0 ; j<indexc ; j++) {
		int encoded = 0;
		int result = TclIndexEncode(interp, indexv[j],
			TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);

		if ((result == TCL_OK) && (encoded == TCL_INDEX_NONE)) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", Tcl_GetString(indexv[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
................................................................................

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    if (index == TCL_INDEX_NONE) {
		index = TCL_INDEX_END - infoPtr->indexv[i];
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element end-%d missing from sublist \"%s\"",
			index, TclGetString(objPtr)));
	    } else {
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element %d missing from sublist \"%s\"",






|







 







|







 







|







 







|







 







|







 







<
<





|
|







 







|







 







|







 







|












|







 







|







 







|


|







 







|
|







 







|


|







 







|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
....
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
....
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
....
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
....
2717
2718
2719
2720
2721
2722
2723


2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
....
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
....
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
....
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
....
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
....
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
....
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
....
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
....
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
/*
 * The "lsort" command needs to pass certain information down to the function
 * that compares two list elements, and the comparison function needs to pass
 * success or failure information back up to the top-level "lsort" command.
 * The following structure is used to pass this information.
 */

typedef struct {
    int isIncreasing;		/* Nonzero means sort in increasing order. */
    int sortMode;		/* The sort mode. One of SORTMODE_* values
				 * defined below. */
    Tcl_Obj *compareCmdPtr;	/* The Tcl comparison command when sortMode is
				 * SORTMODE_COMMAND. Pre-initialized to hold
				 * base of command. */
    int *indexv;		/* If the -index option was specified, this
................................................................................
     * bytecompiled - in that case, the return was a copy of the body's string
     * rep. In order to better isolate the implementation details of the
     * compiler/engine subsystem, we now always return a copy of the string
     * rep. It is important to return a copy so that later manipulations of
     * the object do not invalidate the internal rep.
     */

    bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    if ((objc != 1) && (objc != 2)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
	return TCL_ERROR;
    }

    target = interp;
    if (objc == 2) {
	target = Tcl_GetSlave(interp, TclGetString(objv[1]));
	if (target == NULL) {
	    return TCL_ERROR;
	}
    }

    iPtr = (Interp *) target;
    Tcl_SetObjResult(interp, iPtr->errorStack);
................................................................................
{
    Tcl_Command command;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "commandName");
	return TCL_ERROR;
    }
    command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
	    TCL_LEAVE_ERR_MSG);
    if (command == NULL) {
	return TCL_ERROR;
    }

    /*
     * There's one special case: safe slave interpreters can't see aliases as
................................................................................
	Tcl_SetObjResult(interp, elemPtrs[0]);
	return TCL_OK;
    }

    joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
    Tcl_IncrRefCount(joinObjPtr);

    (void) TclGetStringFromObj(joinObjPtr, &length);
    if (length == 0) {
	resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
    } else {
	int i;

	resObjPtr = Tcl_NewObj();
	for (i = 0;  i < listLen;  i++) {
................................................................................
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */



static int
LremoveIndexCompare(
    const void *el1Ptr,
    const void *el2Ptr)
{
    int idx1 = *((const int *) el1Ptr);
    int idx2 = *((const int *) el2Ptr);

    /*
     * This will put the larger element first.
     */

    return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
................................................................................
Tcl_LremoveObjCmd(
    ClientData notUsed,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, idxc;
    int listLen, *idxv, prevIdx, first, num;
    Tcl_Obj *listObj;

    /*
     * Parse the arguments.
     */

    if (objc < 2) {
................................................................................
    }

    idxc = objc - 2;
    if (idxc == 0) {
	Tcl_SetObjResult(interp, listObj);
	return TCL_OK;
    }
    idxv = ckalloc((objc - 2) * sizeof(int));
    for (i = 2; i < objc; i++) {
	if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
		&idxv[i - 2]) != TCL_OK) {
	    ckfree(idxv);
	    return TCL_ERROR;
	}
    }
................................................................................

    /*
     * Sort the indices, large to small so that when we remove an index we
     * don't change the indices still to be processed.
     */

    if (idxc > 1) {
	qsort(idxv, idxc, sizeof(int), LremoveIndexCompare);
    }

    /*
     * Make our working copy, then do the actual removes piecemeal.
     */

    if (Tcl_IsShared(listObj)) {
	listObj = TclListObjCopy(NULL, listObj);
    }
    num = 0;
    first = listLen;
    for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
	int idx = idxv[i];

	/*
	 * Repeated index and sanity check.
	 */

	if (idx == prevIdx) {
	    continue;
................................................................................
    }

    result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
    if (result != TCL_OK) {
	return result;
    }

    if (first == TCL_INDEX_NONE) {
	first = 0;
    }
    if (first > listLen) {
	first = listLen;
    }

    if (last >= listLen) {
................................................................................

	    for (j=0 ; j<sortInfo.indexc ; j++) {
		int encoded = 0;
		if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
			TCL_INDEX_NONE, &encoded) != TCL_OK) {
		    result = TCL_ERROR;
		}
		if (encoded == (int)TCL_INDEX_NONE) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", TclGetString(indices[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
................................................................................
     */

    if (startPtr) {
	result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
	if (result != TCL_OK) {
	    goto done;
	}
	if (start == TCL_INDEX_NONE) {
	    start = TCL_INDEX_START;
	}

	/*
	 * If the search started past the end of the list, we just return a
	 * "did not match anything at all" result straight away. [Bug 1374778]
	 */

................................................................................
	     */

	    for (j=0 ; j<indexc ; j++) {
		int encoded = 0;
		int result = TclIndexEncode(interp, indexv[j],
			TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);

		if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "index \"%s\" cannot select an element "
			    "from any list", TclGetString(indexv[j])));
		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
			    "OUTOFRANGE", NULL);
		    result = TCL_ERROR;
		}
		if (result == TCL_ERROR) {
		    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			    "\n    (-index option item number %d)", j));
................................................................................

	if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
		&currentObj) != TCL_OK) {
	    infoPtr->resultCode = TCL_ERROR;
	    return NULL;
	}
	if (currentObj == NULL) {
	    if (index == (int)TCL_INDEX_NONE) {
		index = TCL_INDEX_END - infoPtr->indexv[i];
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element end-%d missing from sublist \"%s\"",
			index, TclGetString(objPtr)));
	    } else {
		Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
			"element %d missing from sublist \"%s\"",

Changes to generic/tclCompCmdsGR.c.

429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
...
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
....
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
....
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
....
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
....
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
....
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
....
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
....
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
....
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
....
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
....
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
		jumpFalseDist += 3;
		TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else if (opCode == INST_JUMP_FALSE4) {
		jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else {
		Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
	    }
	}
    }

    /*
     * Free the jumpFixupArray array if malloc'ed storage was used.
     */
................................................................................
    }
    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    objPtr = Tcl_NewObj();
    Tcl_IncrRefCount(objPtr);
    if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
	goto notCompilable;
    }
    bytes = Tcl_GetString(objPtr);

    /*
     * We require that the argument start with "::" and not have any of "*\[?"
     * in it. (Theoretically, we should look in only the final component, but
     * the difference is so slight given current naming practices.)
     */

................................................................................
    }

    /*
     * Generate code to leave the rest of the list on the stack.
     */

    TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx,	envPtr);
    TclEmitInt4(			TCL_INDEX_END,		envPtr);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
     * at this point. We use an [lrange ... 0 end] for this (instead of
     * [llength], as with literals) as we must drop any string representation
     * that might be hanging around.
     */

    if (concat && numWords == 2) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,	envPtr);
	TclEmitInt4(			TCL_INDEX_END,	envPtr);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    if (parsePtr->numWords != 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);

    tokenPtr = TokenAfter(listTokenPtr);
    if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
	    &idx1) != TCL_OK) || (idx1 == TCL_INDEX_NONE)) {
	return TCL_ERROR;
    }
    /*
     * Token was an index value, and we treat all "first" indices
     * before the list same as the start of the list.
     */

................................................................................
     * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
     * this is a splice (== split, insert values as list, concat-3).
     */

    CompileWord(envPtr, listTokenPtr, interp, 1);
    if (parsePtr->numWords == 3) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    for (i=3 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt4(		INST_LIST, i - 3,		envPtr);

    if (idx == TCL_INDEX_START) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else if (idx == TCL_INDEX_END) {
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else {
	/*
	 * Here we handle two ranges for idx. First when idx > 0, we
	 * want the first half of the split to end at index idx-1 and
	 * the second half to start at index idx.
	 * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
................................................................................
	 * we want the first half of the split to end at index end-N and
	 * the second half to start at index end-N+1. We accomplish this
	 * with a pre-adjustment of the end-N value.
	 * The root of this is that the commands [lrange] and [linsert]
	 * differ in their interpretation of the "end" index.
	 */

	if (idx < TCL_INDEX_END) {
	    idx++;
	}
	TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			idx - 1,		envPtr);
	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx,	envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    }

    return TCL_OK;
}
 
................................................................................
     * take advantage.
     *
     * The proper suffix begins with the greater of indices idx1 or
     * idx2 + 1. If we cannot tell at compile time which is greater,
     * we must defer to direct evaluation.
     */

    if (idx1 == TCL_INDEX_NONE) {
	suffixStart = TCL_INDEX_NONE;
    } else if (idx2 == TCL_INDEX_NONE) {
	suffixStart = idx1;
    } else if (idx2 == TCL_INDEX_END) {
	suffixStart = TCL_INDEX_NONE;
    } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
	    || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
    } else {
	return TCL_ERROR;
    }

    /* All paths start with computing/pushing the original value. */
    CompileWord(envPtr, listTokenPtr, interp, 1);
................................................................................
    if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
	/*
	 * This is a "no-op". Example: [lreplace {a b c} 2 0]
	 * We still do a list operation to get list-verification
	 * and canonicalization side effects.
	 */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    if (idx1 != TCL_INDEX_START) {
	/* Prefix may not be empty; generate bytecode to push it */
	if (emptyPrefix) {
	    TclEmitOpcode(	INST_DUP,			envPtr);
	} else {
	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	}
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
................................................................................
	emptyPrefix = 0;
    }

    if (!emptyPrefix) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    }

    if (suffixStart == TCL_INDEX_NONE) {
	TclEmitOpcode(		INST_POP,			envPtr);
	if (emptyPrefix) {
	    PushStringLiteral(envPtr, "");
	}
    } else {
	/* Suffix may not be empty; generate bytecode to push it */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, suffixStart, envPtr);
	TclEmitInt4(			TCL_INDEX_END,		envPtr);
	if (!emptyPrefix) {
	    TclEmitOpcode(	INST_LIST_CONCAT,		envPtr);
	}
    }

    return TCL_OK;
}
................................................................................

    Tcl_DStringInit(&pattern);
    tokenPtr = TokenAfter(tokenPtr);
    patternObj = Tcl_NewObj();
    if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
	goto done;
    }
    if (Tcl_GetString(patternObj)[0] == '-') {
	if (strcmp(Tcl_GetString(patternObj), "--") != 0
		|| parsePtr->numWords == 5) {
	    goto done;
	}
	tokenPtr = TokenAfter(tokenPtr);
	Tcl_DecrRefCount(patternObj);
	patternObj = Tcl_NewObj();
	if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
................................................................................
	    }
	case '\0': case '?': case '[': case '\\':
	    goto done;
	}
	bytes++;
    }
  isSimpleGlob:
    for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
	switch (*bytes) {
	case '\\': case '&':
	    goto done;
	}
    }

    /*






|







 







|







 







|







 







|







 







|







 







|









|


|







 







|







|







 







|
|
|

|
|
|
|







 







|



|







 







|







|







 







|
|







 







|







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
...
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
....
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
....
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
....
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
....
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
....
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
....
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
....
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
....
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
....
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
....
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
		jumpFalseDist += 3;
		TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else if (opCode == INST_JUMP_FALSE4) {
		jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
		jumpFalseDist += 3;
		TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
	    } else {
		Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
	    }
	}
    }

    /*
     * Free the jumpFixupArray array if malloc'ed storage was used.
     */
................................................................................
    }
    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    objPtr = Tcl_NewObj();
    Tcl_IncrRefCount(objPtr);
    if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
	goto notCompilable;
    }
    bytes = TclGetString(objPtr);

    /*
     * We require that the argument start with "::" and not have any of "*\[?"
     * in it. (Theoretically, we should look in only the final component, but
     * the difference is so slight given current naming practices.)
     */

................................................................................
    }

    /*
     * Generate code to leave the rest of the list on the stack.
     */

    TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx,	envPtr);
    TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
     * at this point. We use an [lrange ... 0 end] for this (instead of
     * [llength], as with literals) as we must drop any string representation
     * that might be hanging around.
     */

    if (concat && numWords == 2) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,	envPtr);
	TclEmitInt4(			(int)TCL_INDEX_END,	envPtr);
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
    if (parsePtr->numWords != 4) {
	return TCL_ERROR;
    }
    listTokenPtr = TokenAfter(parsePtr->tokenPtr);

    tokenPtr = TokenAfter(listTokenPtr);
    if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
	    &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) {
	return TCL_ERROR;
    }
    /*
     * Token was an index value, and we treat all "first" indices
     * before the list same as the start of the list.
     */

................................................................................
     * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
     * this is a splice (== split, insert values as list, concat-3).
     */

    CompileWord(envPtr, listTokenPtr, interp, 1);
    if (parsePtr->numWords == 3) {
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    for (i=3 ; i<parsePtr->numWords ; i++) {
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, i);
    }
    TclEmitInstInt4(		INST_LIST, i - 3,		envPtr);

    if (idx == (int)TCL_INDEX_START) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else if (idx == (int)TCL_INDEX_END) {
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    } else {
	/*
	 * Here we handle two ranges for idx. First when idx > 0, we
	 * want the first half of the split to end at index idx-1 and
	 * the second half to start at index idx.
	 * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
................................................................................
	 * we want the first half of the split to end at index end-N and
	 * the second half to start at index end-N+1. We accomplish this
	 * with a pre-adjustment of the end-N value.
	 * The root of this is that the commands [lrange] and [linsert]
	 * differ in their interpretation of the "end" index.
	 */

	if (idx < (int)TCL_INDEX_END) {
	    idx++;
	}
	TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			idx - 1,		envPtr);
	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx,	envPtr);
	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
	TclEmitOpcode(		INST_LIST_CONCAT,		envPtr);
    }

    return TCL_OK;
}
 
................................................................................
     * take advantage.
     *
     * The proper suffix begins with the greater of indices idx1 or
     * idx2 + 1. If we cannot tell at compile time which is greater,
     * we must defer to direct evaluation.
     */

    if (idx1 == (int)TCL_INDEX_NONE) {
	suffixStart = (int)TCL_INDEX_NONE;
    } else if (idx2 == (int)TCL_INDEX_NONE) {
	suffixStart = idx1;
    } else if (idx2 == (int)TCL_INDEX_END) {
	suffixStart = (int)TCL_INDEX_NONE;
    } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END))
	    || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) {
	suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
    } else {
	return TCL_ERROR;
    }

    /* All paths start with computing/pushing the original value. */
    CompileWord(envPtr, listTokenPtr, interp, 1);
................................................................................
    if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
	/*
	 * This is a "no-op". Example: [lreplace {a b c} 2 0]
	 * We still do a list operation to get list-verification
	 * and canonicalization side effects.
	 */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
	return TCL_OK;
    }

    if (idx1 != (int)TCL_INDEX_START) {
	/* Prefix may not be empty; generate bytecode to push it */
	if (emptyPrefix) {
	    TclEmitOpcode(	INST_DUP,			envPtr);
	} else {
	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
	}
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, 0,		envPtr);
................................................................................
	emptyPrefix = 0;
    }

    if (!emptyPrefix) {
	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
    }

    if (suffixStart == (int)TCL_INDEX_NONE) {
	TclEmitOpcode(		INST_POP,			envPtr);
	if (emptyPrefix) {
	    PushStringLiteral(envPtr, "");
	}
    } else {
	/* Suffix may not be empty; generate bytecode to push it */
	TclEmitInstInt4(	INST_LIST_RANGE_IMM, suffixStart, envPtr);
	TclEmitInt4(			(int)TCL_INDEX_END,		envPtr);
	if (!emptyPrefix) {
	    TclEmitOpcode(	INST_LIST_CONCAT,		envPtr);
	}
    }

    return TCL_OK;
}
................................................................................

    Tcl_DStringInit(&pattern);
    tokenPtr = TokenAfter(tokenPtr);
    patternObj = Tcl_NewObj();
    if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
	goto done;
    }
    if (TclGetString(patternObj)[0] == '-') {
	if (strcmp(TclGetString(patternObj), "--") != 0
		|| parsePtr->numWords == 5) {
	    goto done;
	}
	tokenPtr = TokenAfter(tokenPtr);
	Tcl_DecrRefCount(patternObj);
	patternObj = Tcl_NewObj();
	if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
................................................................................
	    }
	case '\0': case '?': case '[': case '\\':
	    goto done;
	}
	bytes++;
    }
  isSimpleGlob:
    for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
	switch (*bytes) {
	case '\\': case '&':
	    goto done;
	}
    }

    /*

Changes to generic/tclCompCmdsSZ.c.

478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
...
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
....
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
....
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
....
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
....
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
	return TCL_OK;
    }

    /* Compute and push the string to be inserted */
    tokenPtr = TokenAfter(tokenPtr);
    CompileWord(envPtr, tokenPtr, interp, 3);

    if (idx == TCL_INDEX_START) {
	/* Prepend the insertion string */
	OP4(	REVERSE, 2);
	OP1(	STR_CONCAT1, 2);
    } else  if (idx == TCL_INDEX_END) {
	/* Append the insertion string */
	OP1(	STR_CONCAT1, 2);
    } else {
	/* Prefix + insertion + suffix */
	if (idx < TCL_INDEX_END) {
	    /* See comments in compiler for [linsert]. */
	    idx++;
	}
	OP4(	OVER, 1);
	OP44(	STR_RANGE_IMM, 0, idx-1);
	OP4(	REVERSE, 3);
	OP44(	STR_RANGE_IMM, idx, TCL_INDEX_END);
................................................................................

    if (parsePtr->numWords == 4) {
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
	}
	str = tokenPtr[1].start;
	length = tokenPtr[1].size;
	if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
	    /*
	     * Fail at run time, not in compilation.
	     */

	    return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
	}
	nocase = 1;
................................................................................
	goto nonConstantIndices;
    }
    /*
     * Token parsed as an index expression. We treat all indices before
     * the string the same as the start of the string.
     */

    if (idx1 == TCL_INDEX_NONE) {
	/* [string range $s end+1 $last] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
................................................................................
	    &idx2) != TCL_OK) {
	goto nonConstantIndices;
    }
    /*
     * Token parsed as an index expression. We treat all indices after
     * the string the same as the end of the string.
     */
    if (idx2 == TCL_INDEX_NONE) {
	/* [string range $s $first -1] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    /*
................................................................................
     *		(last < 0)		OR
     *		(end < first)
     *
     * For some compile-time values we can detect these cases, and
     * compile direct to bytecode implementing the no-op.
     */

    if ((last == TCL_INDEX_NONE)		/* Know (last < 0) */
	    || (first == TCL_INDEX_NONE)	/* Know (first > end) */

	/*
	 * Tricky to determine when runtime (last < first) can be
	 * certainly known based on the encoded values. Consider the
	 * cases...
	 *
	 * (first <= TCL_INDEX_END) &&
	 *	(last <= TCL_INDEX END) && (last < first) => ACCEPT
	 *	else => cannot tell REJECT
	 */
	    || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
		&& (last < first))		/* Know (last < first) */
	/*
	 * (first == TCL_INDEX_NONE) &&
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else		=> (first < last) REJECT
	 *
	 * else [[first >= TCL_INDEX_START]] &&
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
	 */
	    || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
		&& (last < first))) {		/* Know (last < first) */
	if (parsePtr->numWords == 5) {
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp, 4);
	    OP(		POP);		/* Pop newString */
	}
	/* Original string argument now on TOS as result */
................................................................................
     * Considered in combination with the constraints we already have,
     * we see that we can proceed when (first == TCL_INDEX_NONE).
     * These also permit simplification of the prefix|replace|suffix
     * construction. The other constraints, though, interfere with
     * getting a guarantee that first <= last.
     */

    if ((first == TCL_INDEX_START) && (last >= TCL_INDEX_START)) {
	/* empty prefix */
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP4(		REVERSE, 2);
	if (last == INT_MAX) {
	    OP(		POP);		/* Pop  original */
	} else {
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	}
	return TCL_OK;
    }

    if ((last == TCL_INDEX_NONE) && (first <= TCL_INDEX_END)) {
	OP44(		STR_RANGE_IMM, 0, first-1);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP1(		STR_CONCAT1, 2);
	return TCL_OK;
    }

................................................................................
    } else {
	/*
	 * When we have no replacement string to worry about, we may
	 * have more luck, because the forbidden empty string replacements
	 * are harmless when they are replaced by another empty string.
	 */

	if (first == TCL_INDEX_START) {
	    /* empty prefix - build suffix only */

	    if (last == TCL_INDEX_END) {
		/* empty suffix too => empty result */
		OP(	POP);		/* Pop  original */
		PUSH	(	"");
		return TCL_OK;
	    }
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    return TCL_OK;
	} else {
	    if (last == TCL_INDEX_END) {
		/* empty suffix - build prefix only */
		OP44(	STR_RANGE_IMM, 0, first-1);
		return TCL_OK;
	    }
	    OP(		DUP);
	    OP44(	STR_RANGE_IMM, 0, first-1);
	    OP4(	REVERSE, 2);
	    OP44(	STR_RANGE_IMM, last + 1, TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	    return TCL_OK;
	}
    }

    genericReplace:
	tokenPtr = TokenAfter(valueTokenPtr);






|



|




|







 







|







 







|







 







|







 







|
|










|










|







 







|







|





|







 







|


|





|


|







|







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
...
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
....
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
....
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
....
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
....
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
	return TCL_OK;
    }

    /* Compute and push the string to be inserted */
    tokenPtr = TokenAfter(tokenPtr);
    CompileWord(envPtr, tokenPtr, interp, 3);

    if (idx == (int)TCL_INDEX_START) {
	/* Prepend the insertion string */
	OP4(	REVERSE, 2);
	OP1(	STR_CONCAT1, 2);
    } else  if (idx == (int)TCL_INDEX_END) {
	/* Append the insertion string */
	OP1(	STR_CONCAT1, 2);
    } else {
	/* Prefix + insertion + suffix */
	if (idx < (int)TCL_INDEX_END) {
	    /* See comments in compiler for [linsert]. */
	    idx++;
	}
	OP4(	OVER, 1);
	OP44(	STR_RANGE_IMM, 0, idx-1);
	OP4(	REVERSE, 3);
	OP44(	STR_RANGE_IMM, idx, TCL_INDEX_END);
................................................................................

    if (parsePtr->numWords == 4) {
	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	    return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
	}
	str = tokenPtr[1].start;
	length = tokenPtr[1].size;
	if ((length <= 1) || strncmp(str, "-nocase", length)) {
	    /*
	     * Fail at run time, not in compilation.
	     */

	    return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
	}
	nocase = 1;
................................................................................
	goto nonConstantIndices;
    }
    /*
     * Token parsed as an index expression. We treat all indices before
     * the string the same as the start of the string.
     */

    if (idx1 == (int)TCL_INDEX_NONE) {
	/* [string range $s end+1 $last] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
................................................................................
	    &idx2) != TCL_OK) {
	goto nonConstantIndices;
    }
    /*
     * Token parsed as an index expression. We treat all indices after
     * the string the same as the end of the string.
     */
    if (idx2 == (int)TCL_INDEX_NONE) {
	/* [string range $s $first -1] must be empty string */
	OP(		POP);
	PUSH(		"");
	return TCL_OK;
    }

    /*
................................................................................
     *		(last < 0)		OR
     *		(end < first)
     *
     * For some compile-time values we can detect these cases, and
     * compile direct to bytecode implementing the no-op.
     */

    if ((last == (int)TCL_INDEX_NONE)		/* Know (last < 0) */
	    || (first == (int)TCL_INDEX_NONE)	/* Know (first > end) */

	/*
	 * Tricky to determine when runtime (last < first) can be
	 * certainly known based on the encoded values. Consider the
	 * cases...
	 *
	 * (first <= TCL_INDEX_END) &&
	 *	(last <= TCL_INDEX END) && (last < first) => ACCEPT
	 *	else => cannot tell REJECT
	 */
	    || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END)
		&& (last < first))		/* Know (last < first) */
	/*
	 * (first == TCL_INDEX_NONE) &&
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else		=> (first < last) REJECT
	 *
	 * else [[first >= TCL_INDEX_START]] &&
	 *	(last <= TCL_INDEX_END) => cannot tell REJECT
	 *	else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
	 */
	    || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)
		&& (last < first))) {		/* Know (last < first) */
	if (parsePtr->numWords == 5) {
	    tokenPtr = TokenAfter(tokenPtr);
	    CompileWord(envPtr, tokenPtr, interp, 4);
	    OP(		POP);		/* Pop newString */
	}
	/* Original string argument now on TOS as result */
................................................................................
     * Considered in combination with the constraints we already have,
     * we see that we can proceed when (first == TCL_INDEX_NONE).
     * These also permit simplification of the prefix|replace|suffix
     * construction. The other constraints, though, interfere with
     * getting a guarantee that first <= last.
     */

    if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
	/* empty prefix */
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP4(		REVERSE, 2);
	if (last == INT_MAX) {
	    OP(		POP);		/* Pop  original */
	} else {
	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	}
	return TCL_OK;
    }

    if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
	OP44(		STR_RANGE_IMM, 0, first-1);
	tokenPtr = TokenAfter(tokenPtr);
	CompileWord(envPtr, tokenPtr, interp, 4);
	OP1(		STR_CONCAT1, 2);
	return TCL_OK;
    }

................................................................................
    } else {
	/*
	 * When we have no replacement string to worry about, we may
	 * have more luck, because the forbidden empty string replacements
	 * are harmless when they are replaced by another empty string.
	 */

	if (first == (int)TCL_INDEX_START) {
	    /* empty prefix - build suffix only */

	    if (last == (int)TCL_INDEX_END) {
		/* empty suffix too => empty result */
		OP(	POP);		/* Pop  original */
		PUSH	(	"");
		return TCL_OK;
	    }
	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
	    return TCL_OK;
	} else {
	    if (last == (int)TCL_INDEX_END) {
		/* empty suffix - build prefix only */
		OP44(	STR_RANGE_IMM, 0, first-1);
		return TCL_OK;
	    }
	    OP(		DUP);
	    OP44(	STR_RANGE_IMM, 0, first-1);
	    OP4(	REVERSE, 2);
	    OP44(	STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
	    OP1(	STR_CONCAT1, 2);
	    return TCL_OK;
	}
    }

    genericReplace:
	tokenPtr = TokenAfter(valueTokenPtr);

Changes to generic/tclDecls.h.

3982
3983
3984
3985
3986
3987
3988


3989
3990
3991
3992
3993
3994
3995
#undef Tcl_AddErrorInfo
#define Tcl_AddErrorInfo(interp, message) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#undef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo(interp, message, length) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#ifdef TCL_NO_DEPRECATED


#undef Tcl_Eval
#define Tcl_Eval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, -1, 0)
#undef Tcl_GlobalEval
#define Tcl_GlobalEval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
#undef Tcl_SaveResult






>
>







3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
#undef Tcl_AddErrorInfo
#define Tcl_AddErrorInfo(interp, message) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#undef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo(interp, message, length) \
	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#ifdef TCL_NO_DEPRECATED
#undef Tcl_GetStringResult
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#undef Tcl_Eval
#define Tcl_Eval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, -1, 0)
#undef Tcl_GlobalEval
#define Tcl_GlobalEval(interp, objPtr) \
	Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
#undef Tcl_SaveResult

Changes to generic/tclIO.c.

3458
3459
3460
3461
3462
3463
3464





3465
3466
3467
3468
3469
3470
3471
....
4442
4443
4444
4445
4446
4447
4448


4449
4450
4451
4452
4453
4454
4455
....
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
....
8499
8500
8501
8502
8503
8504
8505










8506
8507
8508
8509
8510
8511
8512
....
8526
8527
8528
8529
8530
8531
8532















8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551

8552
8553
8554
8555
8556
8557
8558
	    TclDecrRefCount(statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
    }

    Tcl_ClearChannelHandlers(chan);






    /*
     * Invoke the registered close callbacks and delete their records.
     */

    while (statePtr->closeCbPtr != NULL) {
	cbPtr = statePtr->closeCbPtr;
	statePtr->closeCbPtr = cbPtr->nextPtr;
................................................................................
    }
    if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
	    (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
	if (FlushChannel(NULL, chanPtr, 0) != 0) {
	    return -1;
	}
    }



    return total;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
	     * - It does not process all events in the event queue, but only
	     *	 one, at least in some situations.
	     *
	     * In that case we can get into a situation where
	     *
	     * - Tcl drops READABLE here, because it has data in its own
	     *	 buffers waiting to be read by the extension.
	     * - A READABLE event is syntesized via timer.
	     * - The OS still reports the EXCEPTION condition on the file.
	     * - And the extension gets the EXCPTION event first, and handles
	     *	 this as EOF.
	     *
	     * End result ==> Premature end of reading from a file.
	     *
	     * The concrete example is 'Expect', and its [expect] command
	     * (and at the C-level, deep in the bowels of Expect,
	     * 'exp_get_next_event'. See marker 'SunOS' for commentary in
................................................................................

	    if (!statePtr->timer) {
		statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                        ChannelTimerProc, chanPtr);
	    }
	}
    }










    ChanWatch(chanPtr, mask);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --
................................................................................
static void
ChannelTimerProc(
    ClientData clientData)
{
    Channel *chanPtr = clientData;
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
















    if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
	    && (statePtr->interestMask & TCL_READABLE)
	    && (statePtr->inQueueHead != NULL)
	    && IsBufferReady(statePtr->inQueueHead)) {
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                ChannelTimerProc,chanPtr);
	Tcl_Preserve(statePtr);
	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
	Tcl_Release(statePtr);
    } else {
	statePtr->timer = NULL;
	UpdateInterest(chanPtr);
    }

}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannelHandler --
 *






>
>
>
>
>







 







>
>







 







|

|







 







>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












<

<

<


>







3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
....
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
....
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
....
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
....
8543
8544
8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576

8577

8578

8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
	    TclDecrRefCount(statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
    }

    Tcl_ClearChannelHandlers(chan);

    /*
     * Cancel any outstanding timer.
     */
    Tcl_DeleteTimerHandler(statePtr->timer);

    /*
     * Invoke the registered close callbacks and delete their records.
     */

    while (statePtr->closeCbPtr != NULL) {
	cbPtr = statePtr->closeCbPtr;
	statePtr->closeCbPtr = cbPtr->nextPtr;
................................................................................
    }
    if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
	    (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
	if (FlushChannel(NULL, chanPtr, 0) != 0) {
	    return -1;
	}
    }

    UpdateInterest(chanPtr);

    return total;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
	     * - It does not process all events in the event queue, but only
	     *	 one, at least in some situations.
	     *
	     * In that case we can get into a situation where
	     *
	     * - Tcl drops READABLE here, because it has data in its own
	     *	 buffers waiting to be read by the extension.
	     * - A READABLE event is synthesized via timer.
	     * - The OS still reports the EXCEPTION condition on the file.
	     * - And the extension gets the EXCEPTION event first, and handles
	     *	 this as EOF.
	     *
	     * End result ==> Premature end of reading from a file.
	     *
	     * The concrete example is 'Expect', and its [expect] command
	     * (and at the C-level, deep in the bowels of Expect,
	     * 'exp_get_next_event'. See marker 'SunOS' for commentary in
................................................................................

	    if (!statePtr->timer) {
		statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                        ChannelTimerProc, chanPtr);
	    }
	}
    }

    if (!statePtr->timer
	&& mask & TCL_WRITABLE
	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {

	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
	    ChannelTimerProc,chanPtr);
    }


    ChanWatch(chanPtr, mask);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --
................................................................................
static void
ChannelTimerProc(
    ClientData clientData)
{
    Channel *chanPtr = clientData;
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */

    Tcl_Preserve(statePtr);
    statePtr->timer = NULL;
    if (statePtr->interestMask & TCL_WRITABLE
	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
	&& !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
	) {
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */
	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                ChannelTimerProc,chanPtr);
	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
    }

    if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
	    && (statePtr->interestMask & TCL_READABLE)
	    && (statePtr->inQueueHead != NULL)
	    && IsBufferReady(statePtr->inQueueHead)) {
	/*
	 * Restart the timer in case a channel handler reenters the event loop
	 * before UpdateInterest gets called by Tcl_NotifyChannel.
	 */

	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
                ChannelTimerProc,chanPtr);

	Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);

    } else {

	UpdateInterest(chanPtr);
    }
    Tcl_Release(statePtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannelHandler --
 *

Changes to generic/tclIORChan.c.

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */

    Tcl_TimerToken readTimer;   /* 
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is readable 
			        */
    Tcl_TimerToken writeTimer;  /* 
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is writable 
			        */

    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file






|


|

|


|







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */

    Tcl_TimerToken readTimer;   /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is readable
			        */
    Tcl_TimerToken writeTimer;  /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is writable
			        */

    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file

Changes to generic/tclInt.h.

3102
3103
3104
3105
3106
3107
3108

3109
3110
3111
3112
3113
3114
3115
....
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);

MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, const char *operation,
			    const char *reason, int index);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
................................................................................
	    (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
	} else {							\
	    (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1;	\
	    (bignum).sign = bignumPayload >> 30;			\
	    (bignum).alloc = (bignumPayload >> 15) & 0x7fff;		\
	    (bignum).used = bignumPayload & 0x7fff;			\
	}								\
    } while (0) 

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
 * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
 * "prototype" for this macro is:
 *






>







 







|







3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
....
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
			    int *codePtr, int *levelPtr);
MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
MODULE_SCOPE int	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE int	TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, const char *operation,
			    const char *reason, int index);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
................................................................................
	    (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
	} else {							\
	    (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1;	\
	    (bignum).sign = bignumPayload >> 30;			\
	    (bignum).alloc = (bignumPayload >> 15) & 0x7fff;		\
	    (bignum).used = bignumPayload & 0x7fff;			\
	}								\
    } while (0)

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
 * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
 * "prototype" for this macro is:
 *

Changes to generic/tclLink.c.

23
24
25
26
27
28
29

30
31
32
33
34
35
36
...
154
155
156
157
158
159
160


161
162
163
164
165
166
167
168
169
170
171
172

173
174
175
176
177
178
179
...
192
193
194
195
196
197
198





199
200
201
202
203
204
205
...
236
237
238
239
240
241
242


243
244
245
246
247
248
249
...
358
359
360
361
362
363
364





365
366
367
368
369
370
371
...
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
...
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
....
1493
1494
1495
1496
1497
1498
1499



1500
1501
1502
1503
1504
1505
1506
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl
 * variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */

    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    void *addr;			/* Location of C variable. */
    int bytes;			/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
................................................................................
    void *addr,			/* Address of a C variable to be linked to
				 * varName. */
    int type)			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;


    int code;

    linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
    if (linkPtr != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"variable '%s' is already linked", varName));
	return TCL_ERROR;
    }

    linkPtr = ckalloc(sizeof(Link));
    linkPtr->interp = interp;

    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);
    linkPtr->addr = addr;
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))
    if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
................................................................................
    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }





    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
    }
................................................................................
				 * interpreter result. */
    int type,			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
    int size)			/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;


    int code;

    if (size < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"wrong array size given", -1));
	return TCL_ERROR;
    }
................................................................................
    /*
     * Set common structure values.
     */

    linkPtr->interp = interp;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);





    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }
................................................................................

    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
    } else {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) linkPtr->addr));
    }
    return code;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (Tcl_InterpDeleted(interp)) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    LinkFree(linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
................................................................................
 *----------------------------------------------------------------------
 */

static void
LinkFree(
    Link *linkPtr)		/* Structure describing linked variable. */
{



    if (linkPtr->flags & LINK_ALLOC_ADDR) {
	ckfree(linkPtr->addr);
    }
    if (linkPtr->flags & LINK_ALLOC_LAST) {
	ckfree(linkPtr->lastValue.aryPtr);
    }
    ckfree((char *) linkPtr);






>







 







>
>












>







 







>
>
>
>
>







 







>
>







 







>
>
>
>
>







 







<
<







 







|







 







>
>
>







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
...
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
...
388
389
390
391
392
393
394


395
396
397
398
399
400
401
...
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
....
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
 * For each linked variable there is a data structure of the following type,
 * which describes the link and is the clientData for the trace set on the Tcl
 * variable.
 */

typedef struct Link {
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    Namespace *nsPtr;		/* Namespace containing Tcl variable */
    Tcl_Obj *varName;		/* Name of variable (must be global). This is
				 * needed during trace callbacks, since the
				 * actual variable may be aliased at that time
				 * via upvar. */
    void *addr;			/* Location of C variable. */
    int bytes;			/* Size of C variable array. This is 0 when
				 * single variables, and >0 used for array
................................................................................
    void *addr,			/* Address of a C variable to be linked to
				 * varName. */
    int type)			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    Namespace *dummy;
    const char *name;
    int code;

    linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
    if (linkPtr != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"variable '%s' is already linked", varName));
	return TCL_ERROR;
    }

    linkPtr = ckalloc(sizeof(Link));
    linkPtr->interp = interp;
    linkPtr->nsPtr = NULL;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);
    linkPtr->addr = addr;
    linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
	|| defined(_WIN32) || defined(__CYGWIN__))
    if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
................................................................................
    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }

    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
    linkPtr->nsPtr->refCount++;

    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
    }
................................................................................
				 * interpreter result. */
    int type,			/* Type of C variable: TCL_LINK_INT, etc. Also
				 * may have TCL_LINK_READ_ONLY OR'ed in. */
    int size)			/* Size of C variable array, >1 if array */
{
    Tcl_Obj *objPtr;
    Link *linkPtr;
    Namespace *dummy;
    const char *name;
    int code;

    if (size < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"wrong array size given", -1));
	return TCL_ERROR;
    }
................................................................................
    /*
     * Set common structure values.
     */

    linkPtr->interp = interp;
    linkPtr->varName = Tcl_NewStringObj(varName, -1);
    Tcl_IncrRefCount(linkPtr->varName);

    TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
	    &(linkPtr->nsPtr), &dummy, &dummy, &name);
    linkPtr->nsPtr->refCount++;

    objPtr = ObjValue(linkPtr);
    if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);
	return TCL_ERROR;
    }
................................................................................

    code = Tcl_TraceVar2(interp, varName, NULL,
	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
	    LinkTraceProc, linkPtr);
    if (code != TCL_OK) {
	Tcl_DecrRefCount(linkPtr->varName);
	LinkFree(linkPtr);


    }
    return code;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................

    /*
     * If the variable is being unset, then just re-create it (with a trace)
     * unless the whole interpreter is going away.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
	    Tcl_DecrRefCount(linkPtr->varName);
	    LinkFree(linkPtr);
	} else if (flags & TCL_TRACE_DESTROYED) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	    Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
		    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
................................................................................
 *----------------------------------------------------------------------
 */

static void
LinkFree(
    Link *linkPtr)		/* Structure describing linked variable. */
{
    if (linkPtr->nsPtr) {
	TclNsDecrRefCount(linkPtr->nsPtr);
    }
    if (linkPtr->flags & LINK_ALLOC_ADDR) {
	ckfree(linkPtr->addr);
    }
    if (linkPtr->flags & LINK_ALLOC_LAST) {
	ckfree(linkPtr->lastValue.aryPtr);
    }
    ckfree((char *) linkPtr);

Changes to generic/tclNamesp.c.

1082
1083
1084
1085
1086
1087
1088







1089
1090
1091
1092
1093
1094
1095
	     */

	    nsPtr->flags &= ~(NS_DYING|NS_KILLED);
	}
    }
    TclNsDecrRefCount(nsPtr);
}







 
/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *	Used internally to dismantle and unlink a namespace when it is






>
>
>
>
>
>
>







1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
	     */

	    nsPtr->flags &= ~(NS_DYING|NS_KILLED);
	}
    }
    TclNsDecrRefCount(nsPtr);
}

int
TclNamespaceDeleted(
    Namespace *nsPtr)
{
    return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclTeardownNamespace --
 *
 *	Used internally to dismantle and unlink a namespace when it is

Changes to generic/tclOO.c.

342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
...
870
871
872
873
874
875
876

877


878
879
880

881
882
883
884
885
886
887
...
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
...
914
915
916
917
918
919
920
921

922
923
924
925
926
927
928
....
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136

1137


1138
1139
1140
1141
1142
1143
1144
....
1146
1147
1148
1149
1150
1151
1152
1153
1154

1155
1156
1157
1158
1159
1160
1161
....
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
....
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
....
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
....
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
....
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
....
1970
1971
1972
1973
1974
1975
1976


1977


1978
1979
1980
1981
1982
1983
1984
....
2008
2009
2010
2011
2012
2013
2014

2015
2016
2017
2018
2019
2020
2021
....
2071
2072
2073
2074
2075
2076
2077

2078
2079
2080

2081
2082
2083
2084
2085
2086
2087
....
2117
2118
2119
2120
2121
2122
2123


2124


2125
2126
2127
2128
2129
2130
2131
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
....
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i=0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i=0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

................................................................................

    InitClassSystemRoots(interp, fPtr);

    /*
     * Basic method declarations for the core classes.
     */

    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

    if (fPtr->helpersNs != NULL) {
................................................................................

    /*
     * Squelch classes that this class has been mixed into.
     */

    if (clsPtr->mixinSubs.num > 0) {
	while (clsPtr->mixinSubs.num > 0) {

	    mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];


	    /* This condition also covers the case where mixinSubclassPtr ==
	     * clsPtr
	     */

	    if (!Deleted(mixinSubclassPtr->thisPtr)
		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];

	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr) &&
		    !(instancePtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
................................................................................
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Deleted(oPtr)) {
	/*
	 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
	 * guard could be removed.
	 */

	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookeeping
     * records.  This is the flag that
     */

    oPtr->flags |= OBJECT_DELETED;


    /* Let the dominoes fall */


    if (oPtr->classPtr) {
	TclOODeleteDescendants(interp, oPtr);
    }

    /*
     * We do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
................................................................................
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;

	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
................................................................................
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * 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_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
................................................................................
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

    /*
     * TODO: Should this be protected with a * !IsRoot() condition?
     */

    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
................................................................................
     */

    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

 
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
................................................................................
{
    Tcl_HashEntry *hPtr;
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    const char *simpleName = NULL;
    Namespace *nsPtr = NULL, *dummy;
    Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    int isNew;

    if (nameStr) {
	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);

	/*
	 * Disallow creation of an object over an existing command.
	 */

	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't create object \"%s\": command already exists with"
		    " that name", nameStr));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	    return NULL;
	}

	/*
	 * We could make a hash entry! Don't actually want to do that here so
	 * nuke it immediately because we'll create it properly soon.
	 */

	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
................................................................................
	TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
    } else {
	oPtr->classPtr = NULL;
    }
    return oPtr;
}
 


static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
................................................................................
	ckfree(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}


	/* For the reference just created in DUPLICATE */


	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

................................................................................
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value, duplicate;
................................................................................
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);


	    /* For the new item in cls2Ptr->superclasses that memcpy just
	     * created
	     */

	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

................................................................................
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);


	    /* For the copy just created in DUPLICATE */


	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

................................................................................
    int skip)
{
    CallContext *contextPtr = (CallContext *) context;
    int savedIndex = contextPtr->index;
    int savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

................................................................................
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv,
    int skip)
{
    register CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */







|






|







 







|


|











|







 







<

<
|







 







>
|
>
>
|


>







 







|







 







|
>







 







|
|













>
|
>
>







 







<

>







 







|
|
|


|







 







<
|
<
<







 







<







 







<









|
|






<
<
<
<
<
<
<







 







<
<







 







>
>
|
>
>







 







>







 







>
|
|

>







 







>
>
|
>
>







 







|







 







|







342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
...
663
664
665
666
667
668
669

670

671
672
673
674
675
676
677
678
...
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
...
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
...
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
....
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
....
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166
1167
....
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
....
1203
1204
1205
1206
1207
1208
1209

1210


1211
1212
1213
1214
1215
1216
1217
....
1764
1765
1766
1767
1768
1769
1770

1771
1772
1773
1774
1775
1776
1777
....
1778
1779
1780
1781
1782
1783
1784

1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801







1802
1803
1804
1805
1806
1807
1808
....
1827
1828
1829
1830
1831
1832
1833


1834
1835
1836
1837
1838
1839
1840
....
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
....
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
....
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
....
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
....
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
....
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i = 0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i = 0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

................................................................................

    InitClassSystemRoots(interp, fPtr);

    /*
     * Basic method declarations for the core classes.
     */

    for (i = 0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i = 0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *) oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

    if (fPtr->helpersNs != NULL) {
................................................................................

    /*
     * Squelch classes that this class has been mixed into.
     */

    if (clsPtr->mixinSubs.num > 0) {
	while (clsPtr->mixinSubs.num > 0) {
	    mixinSubclassPtr =
		    clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];

	    /*
	     * This condition also covers the case where mixinSubclassPtr ==
	     * clsPtr
	     */

	    if (!Deleted(mixinSubclassPtr->thisPtr)
		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];

	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr) &&
		    !(instancePtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
................................................................................
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Deleted(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
	 * this guard could be removed.
	 */

	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookeeping
     * records.  This is the flag that
     */

    oPtr->flags |= OBJECT_DELETED;

    /*
     * Let the dominoes fall!
     */

    if (oPtr->classPtr) {
	TclOODeleteDescendants(interp, oPtr);
    }

    /*
     * We do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
................................................................................
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;

	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
................................................................................
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * 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_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
................................................................................
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */


    /* TODO: Should this be protected with a !IsRoot() condition? */


    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
................................................................................
     */

    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

 
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
................................................................................
{
    Tcl_HashEntry *hPtr;
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    const char *simpleName = NULL;
    Namespace *nsPtr = NULL, *dummy;
    Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);


    if (nameStr) {
	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);

	/*
	 * Disallow creation of an object over an existing command.
	 */

	hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
	if (hPtr) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't create object \"%s\": command already exists with"
		    " that name", nameStr));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	    return NULL;
	}







    }

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
................................................................................
	TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
    } else {
	oPtr->classPtr = NULL;
    }
    return oPtr;
}
 


static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
................................................................................
	ckfree(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}

	/*
	 * For the reference just created in DUPLICATE.
	 */

	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

................................................................................
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value, duplicate;
................................................................................
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);

	    /*
	     * For the new item in cls2Ptr->superclasses that memcpy just
	     * created.
	     */

	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

................................................................................
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    ckfree(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);

	    /*
	     * For the copy just created in DUPLICATE.
	     */

	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

................................................................................
    int skip)
{
    CallContext *contextPtr = (CallContext *) context;
    int savedIndex = contextPtr->index;
    int savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

................................................................................
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv,
    int skip)
{
    register CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

Changes to generic/tclOOCall.c.

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
...
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
...
637
638
639
640
641
642
643

644


645
646
647
648
649
650
651
....
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
....
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */
................................................................................
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    int i;

    for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
    } else {
	ckfree(strings);
	*stringsPtr = NULL;
    }
    return i;
}


/* Comparator for SortMethodNames */


static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;
................................................................................
    }

    /*
     * First test whether the method is already in the call chain. Skip over
     * any leading filters.
     */

    for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
	if (callPtr->chain[i].mPtr == mPtr &&
		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     */

	    Class *declCls = callPtr->chain[i].filterDeclarer;

	    for (; i+1<callPtr->numChain ; i++) {
		callPtr->chain[i] = callPtr->chain[i+1];
	    }
	    callPtr->chain[i].mPtr = mPtr;
	    callPtr->chain[i].isFilter = (doneFilters != NULL);
	    callPtr->chain[i].filterDeclarer = declCls;
	    return;
	}
    }
................................................................................
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i=0 ; i<callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;






|







 







|







 







>
|
>
>







 







|











|
|







 







|







324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
...
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
...
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
....
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
....
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */
................................................................................
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    int i;

    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
    } else {
	ckfree(strings);
	*stringsPtr = NULL;
    }
    return i;
}

/*
 * Comparator for SortMethodNames
 */

static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;
................................................................................
    }

    /*
     * First test whether the method is already in the call chain. Skip over
     * any leading filters.
     */

    for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
	if (callPtr->chain[i].mPtr == mPtr &&
		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     */

	    Class *declCls = callPtr->chain[i].filterDeclarer;

	    for (; i + 1 < callPtr->numChain ; i++) {
		callPtr->chain[i] = callPtr->chain[i + 1];
	    }
	    callPtr->chain[i].mPtr = mPtr;
	    callPtr->chain[i].isFilter = (doneFilters != NULL);
	    callPtr->chain[i].filterDeclarer = declCls;
	    return;
	}
    }
................................................................................
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i = 0 ; i < callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;

Changes to generic/tclOODefineCmds.c.

45
46
47
48
49
50
51






52
53
54
55
56
57
58
...
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
...
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
...
396
397
398
399
400
401
402


403


404
405
406
407
408
409
410
...
448
449
450
451
452
453
454


455


456
457
458
459
460
461
462
...
720
721
722
723
724
725
726

727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
....
1035
1036
1037
1038
1039
1040
1041

1042


1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
....
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
....
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
....
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
....
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
....
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
....
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
....
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
....
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
....
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
....
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
....
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
....
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
....
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
....
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
....
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
....
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
		    resolver, NULL, NULL}}







/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (oPtr->filters.num == 0) {
	    filtersList = ckalloc(size);
	} else {
	    filtersList = ckrealloc(oPtr->filters.list, size);
	}
	for (i=0 ; i<numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (classPtr->filters.num == 0) {
	    filtersList = ckalloc(size);
	} else {
	    filtersList = ckrealloc(classPtr->filters.list, size);
	}
	for (i=0 ; i<numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	classPtr->filters.list = filtersList;
	classPtr->filters.num = numFilters;
    }

................................................................................
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);


		/* For the new copy created by memcpy */


		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
................................................................................
	} else {
	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);


	    /* For the new copy created by memcpy */


	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
................................................................................
    }

    if (matchedStr != NULL) {
	/*
	 * Got one match, and only one match!
	 */


	Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
	}
	result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);
	return result;
    }

  noMatch:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
................................................................................
     * comments above for why these contortions are necessary.
     */

    objPtr = Tcl_NewObj();
    obj2Ptr = Tcl_NewObj();
    cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
    if (cmd == NULL) {

	/* punt this case! */


	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
    } else {
	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
    }
    Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
    /* TODO: overflow? */
    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
    Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);

    result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
    if (isRoot) {
	TclResetRewriteEnsemble(interp, 1);
    }
    Tcl_DecrRefCount(objPtr);

    return result;
}
................................................................................
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i=1 ; i<objc ; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
	 */

	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	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 (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method structure.
     */

    prefixObj = Tcl_NewListObj(objc-2, objv+2);
    if (isInstanceForward) {
	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
		prefixObj);
    } else {
	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
		objv[1], prefixObj);
    }
................................................................................
	    isPublic = 0;
	    break;
	}
    } else {
	if (IsPrivateDefine(interp)) {
	    isPublic = TRUE_PRIVATE_METHOD;
	} else {
	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
		    ? PUBLIC_METHOD : 0;
	}
    }

    /*
     * Create the method by using the right back-end API.
     */
................................................................................
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i=1 ; i<objc ; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from 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 without that flag;
	 * such records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int superc, i, j;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;
	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i=0 ; i<superc ; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;
		goto failedAfterAlloc;
	    }
	    for (j=0 ; j<i ; j++) {
		if (superclasses[j] == superclasses[i]) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "class should only be a direct superclass once",
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
    }
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);






>
>
>
>
>
>







 







|







 







|







 







>
>
|
>
>







 







>
>
|
>
>







 







>
|





|

|







 







>
|
>
>






|


|







 







|







 







|







 







|









|







 







|







 







|







 







|







 







|







 







|







 







|







 







|






|







 







|







 







|







 







|







 







|







 







|







 







|












|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
...
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
...
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
...
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
...
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
...
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
....
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
....
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
....
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
....
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
....
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
....
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
....
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
....
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
....
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
....
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
....
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
....
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
....
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
....
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
....
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
....
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
....
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
		    resolver, NULL, NULL}}

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

#define PUBLIC_PATTERN		"[a-z]*"

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (oPtr->filters.num == 0) {
	    filtersList = ckalloc(size);
	} else {
	    filtersList = ckrealloc(oPtr->filters.list, size);
	}
	for (i = 0 ; i < numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (classPtr->filters.num == 0) {
	    filtersList = ckalloc(size);
	} else {
	    filtersList = ckrealloc(classPtr->filters.list, size);
	}
	for (i = 0 ; i < numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	classPtr->filters.list = filtersList;
	classPtr->filters.num = numFilters;
    }

................................................................................
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);

		/*
		 * For the new copy created by memcpy().
		 */

		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
................................................................................
	} else {
	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);

	    /*
	     * For the new copy created by memcpy.
	     */

	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
................................................................................
    }

    if (matchedStr != NULL) {
	/*
	 * Got one match, and only one match!
	 */

	Tcl_Obj **newObjv =
		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
	}
	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);
	return result;
    }

  noMatch:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
................................................................................
     * comments above for why these contortions are necessary.
     */

    objPtr = Tcl_NewObj();
    obj2Ptr = Tcl_NewObj();
    cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
    if (cmd == NULL) {
	/*
	 * Punt this case!
	 */

	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
    } else {
	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
    }
    Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
    /* TODO: overflow? */
    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
    Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);

    result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
    if (isRoot) {
	TclResetRewriteEnsemble(interp, 1);
    }
    Tcl_DecrRefCount(objPtr);

    return result;
}
................................................................................
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
	 */

	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	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 (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method structure.
     */

    prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
    if (isInstanceForward) {
	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
		prefixObj);
    } else {
	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
		objv[1], prefixObj);
    }
................................................................................
	    isPublic = 0;
	    break;
	}
    } else {
	if (IsPrivateDefine(interp)) {
	    isPublic = TRUE_PRIVATE_METHOD;
	} else {
	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
		    ? PUBLIC_METHOD : 0;
	}
    }

    /*
     * Create the method by using the right back-end API.
     */
................................................................................
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from 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 without that flag;
	 * such records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int superc, i, j;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;
	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i = 0; i < superc; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;
		goto failedAfterAlloc;
	    }
	    for (j = 0; j < i; j++) {
		if (superclasses[j] == superclasses[i]) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "class should only be a direct superclass once",
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i = 0; i < varc; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
    }
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i = 0; i < varc; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);

Changes to generic/tclResult.c.

460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
...
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505

506
507
508
509
510
511
512
    /*
     * Reset the object result since we just set the string result.
     */

    ResetObjResult(iPtr);
}
#endif /* !TCL_NO_DEPRECATED */
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringResult --
 *
 *	Returns an interpreter's result value as a string.
................................................................................
 */

const char *
Tcl_GetStringResult(
    register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
    Interp *iPtr = (Interp *) interp;
#ifdef TCL_NO_DEPRECATED
    return Tcl_GetString(iPtr->objResultPtr);
#else
    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    if (*(iPtr->result) == 0) {
	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
		TCL_VOLATILE);
    }
    return iPtr->result;
#endif
}

 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjResult --
 *
 *	Arrange for objPtr to be an interpreter's result value.






<







 







<
<
<










<

>







460
461
462
463
464
465
466

467
468
469
470
471
472
473
...
483
484
485
486
487
488
489



490
491
492
493
494
495
496
497
498
499

500
501
502
503
504
505
506
507
508
    /*
     * Reset the object result since we just set the string result.
     */

    ResetObjResult(iPtr);
}

 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetStringResult --
 *
 *	Returns an interpreter's result value as a string.
................................................................................
 */

const char *
Tcl_GetStringResult(
    register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
    Interp *iPtr = (Interp *) interp;



    /*
     * If the string result is empty, move the object result to the string
     * result, then reset the object result.
     */

    if (*(iPtr->result) == 0) {
	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
		TCL_VOLATILE);
    }
    return iPtr->result;

}
#endif /* !TCL_NO_DEPRECATED */
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjResult --
 *
 *	Arrange for objPtr to be an interpreter's result value.

Changes to generic/tclStrToD.c.

1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
....
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
....
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
....
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
....
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
....
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
....
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
....
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
....
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
     * significand (the most significant) corresponds to the
     * 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold
     * that quantity, then convert the significand to a large integer, scaled
     * appropriately. Then multiply by the appropriate power of 5.
     */

    msb = binExponent + M2;	/* 1008 */
    nDigits = msb / DIGIT_BIT + 1;
    mp_init_size(&twoMv, nDigits);
    i = (msb % DIGIT_BIT + 1);
    twoMv.used = nDigits;
    significand *= SafeLdExp(1.0, i);
    while (--nDigits >= 0) {
	twoMv.dp[nDigits] = (mp_digit) significand;
	significand -= (mp_digit) significand;
	significand = SafeLdExp(significand, DIGIT_BIT);
    }
    for (i = 0; i <= 8; ++i) {
	if (M5 & (1 << i)) {
	    mp_mul(&twoMv, pow5+i, &twoMv);
	}
    }

................................................................................
static inline int
ShouldBankerRoundUpPowD(
    mp_int *b,			/* Numerator of the fraction. */
    int sd,			/* Denominator is 2**(sd*DIGIT_BIT). */
    int isodd)			/* 1 if the digit is odd, 0 if even. */
{
    int i;
    static const mp_digit topbit = ((mp_digit)1) << (DIGIT_BIT - 1);

    if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
	return 0;
    }
    if (b->dp[sd-1] != topbit) {
	return 1;
    }
................................................................................
	     * The denominator is a power of 2, so we can replace division by
	     * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
	     * and adjust m2 and b2 accordingly. Then we launch into a version
	     * of the comparison that's specialized for the 'power of mp_digit
	     * in the denominator' case.
	     */

	    if (s2 % DIGIT_BIT != 0) {
		int delta = DIGIT_BIT - (s2 % DIGIT_BIT);

		b2 += delta;
		m2plus += delta;
		m2minus += delta;
		s2 += delta;
	    }
	    return ShorteningBignumConversionPowD(&d, bw, b2, b5,
		    m2plus, m2minus, m5, s2/DIGIT_BIT, k, len, ilim, ilim1,
		    decpt, endPtr);
	} else {
	    /*
	     * Alas, there's no helpful special case; use full-up bignum
	     * arithmetic for the conversion.
	     */

................................................................................
	     * The denominator is a power of 2, so we can replace division by
	     * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
	     * and adjust m2 and b2 accordingly. Then we launch into a version
	     * of the comparison that's specialized for the 'power of mp_digit
	     * in the denominator' case.
	     */

	    if (s2 % DIGIT_BIT != 0) {
		int delta = DIGIT_BIT - (s2 % DIGIT_BIT);

		b2 += delta;
		s2 += delta;
	    }
	    return StrictBignumConversionPowD(&d, bw, b2, b5,
		    s2/DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
	} else {
	    /*
	     * There are no helpful special cases, but at least we know in
	     * advance how many digits we will convert. We can run the
	     * conversion in steps of DIGIT_GROUP digits, so as to have many
	     * fewer mp_int divisions.
	     */
................................................................................
     * the significand of a double.
     */

    maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
	    + 0.5 * log(10.)) / log(10.));
    minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
	    * log((double) FLT_RADIX) / log(10.));
    log10_DIGIT_MAX = (int) floor(DIGIT_BIT * log(2.) / log(10.));

    /*
     * Nokia 770's software-emulated floating point is "middle endian": the
     * bytes within a 32-bit word are little-endian (like the native
     * integers), but the two words of a 'double' are presented most
     * significant word first.
     */
................................................................................

    /*
     * Accumulate the result, one mp_digit at a time.
     */

    r = 0.0;
    for (i=b.used-1 ; i>=0 ; --i) {
	r = ldexp(r, DIGIT_BIT) + b.dp[i];
    }
    mp_clear(&b);

    /*
     * Scale the result to the correct number of bits.
     */

................................................................................
	    } else {
		mp_copy(a, &b);
	    }
	    if (!exact) {
		mp_add_d(&b, 1, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}
................................................................................
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_div_2d(a, -shift, &b, NULL);
	    } else {
		mp_copy(a, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}
................................................................................

    /*
     * Accumulate the result, one mp_digit at a time.
     */

    r = 0.0;
    for (i=b.used-1; i>=0; --i) {
	r = ldexp(r, DIGIT_BIT) + b.dp[i];
    }
    mp_clear(&b);

    /*
     * Return the result with the appropriate sign.
     */







|

|





|







 







|







 







|
|







|







 







|
|





|







 







|







 







|







 







|







 







|







 







|







1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
....
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
....
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
....
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
....
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
....
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
....
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
....
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
....
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
     * significand (the most significant) corresponds to the
     * 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold
     * that quantity, then convert the significand to a large integer, scaled
     * appropriately. Then multiply by the appropriate power of 5.
     */

    msb = binExponent + M2;	/* 1008 */
    nDigits = msb / MP_DIGIT_BIT + 1;
    mp_init_size(&twoMv, nDigits);
    i = (msb % MP_DIGIT_BIT + 1);
    twoMv.used = nDigits;
    significand *= SafeLdExp(1.0, i);
    while (--nDigits >= 0) {
	twoMv.dp[nDigits] = (mp_digit) significand;
	significand -= (mp_digit) significand;
	significand = SafeLdExp(significand, MP_DIGIT_BIT);
    }
    for (i = 0; i <= 8; ++i) {
	if (M5 & (1 << i)) {
	    mp_mul(&twoMv, pow5+i, &twoMv);
	}
    }

................................................................................
static inline int
ShouldBankerRoundUpPowD(
    mp_int *b,			/* Numerator of the fraction. */
    int sd,			/* Denominator is 2**(sd*DIGIT_BIT). */
    int isodd)			/* 1 if the digit is odd, 0 if even. */
{
    int i;
    static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1);

    if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
	return 0;
    }
    if (b->dp[sd-1] != topbit) {
	return 1;
    }
................................................................................
	     * The denominator is a power of 2, so we can replace division by
	     * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
	     * and adjust m2 and b2 accordingly. Then we launch into a version
	     * of the comparison that's specialized for the 'power of mp_digit
	     * in the denominator' case.
	     */

	    if (s2 % MP_DIGIT_BIT != 0) {
		int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);

		b2 += delta;
		m2plus += delta;
		m2minus += delta;
		s2 += delta;
	    }
	    return ShorteningBignumConversionPowD(&d, bw, b2, b5,
		    m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1,
		    decpt, endPtr);
	} else {
	    /*
	     * Alas, there's no helpful special case; use full-up bignum
	     * arithmetic for the conversion.
	     */

................................................................................
	     * The denominator is a power of 2, so we can replace division by
	     * digit shifts. First we round up s2 to a multiple of DIGIT_BIT,
	     * and adjust m2 and b2 accordingly. Then we launch into a version
	     * of the comparison that's specialized for the 'power of mp_digit
	     * in the denominator' case.
	     */

	    if (s2 % MP_DIGIT_BIT != 0) {
		int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);

		b2 += delta;
		s2 += delta;
	    }
	    return StrictBignumConversionPowD(&d, bw, b2, b5,
		    s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
	} else {
	    /*
	     * There are no helpful special cases, but at least we know in
	     * advance how many digits we will convert. We can run the
	     * conversion in steps of DIGIT_GROUP digits, so as to have many
	     * fewer mp_int divisions.
	     */
................................................................................
     * the significand of a double.
     */

    maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
	    + 0.5 * log(10.)) / log(10.));
    minDigits = (int) floor((DBL_MIN_EXP - DBL_MANT_DIG)
	    * log((double) FLT_RADIX) / log(10.));
    log10_DIGIT_MAX = (int) floor(MP_DIGIT_BIT * log(2.) / log(10.));

    /*
     * Nokia 770's software-emulated floating point is "middle endian": the
     * bytes within a 32-bit word are little-endian (like the native
     * integers), but the two words of a 'double' are presented most
     * significant word first.
     */
................................................................................

    /*
     * Accumulate the result, one mp_digit at a time.
     */

    r = 0.0;
    for (i=b.used-1 ; i>=0 ; --i) {
	r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
    }
    mp_clear(&b);

    /*
     * Scale the result to the correct number of bits.
     */

................................................................................
	    } else {
		mp_copy(a, &b);
	    }
	    if (!exact) {
		mp_add_d(&b, 1, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}
................................................................................
		mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_div_2d(a, -shift, &b, NULL);
	    } else {
		mp_copy(a, &b);
	    }
	    for (i=b.used-1 ; i>=0 ; --i) {
		r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
	    }
	    r = ldexp(r, bits - mantBits);
	}
    }
    mp_clear(&b);
    return r;
}
................................................................................

    /*
     * Accumulate the result, one mp_digit at a time.
     */

    r = 0.0;
    for (i=b.used-1; i>=0; --i) {
	r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
    }
    mp_clear(&b);

    /*
     * Return the result with the appropriate sign.
     */

Changes to generic/tclStringObj.c.

2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
....
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
#endif
		} else if (useBig && big.used) {
		    int leftover = (big.used * DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
			numDigits--;
			mask >>= numBits;
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
................................................................................
		bytes = TclGetString(pure);
		toAppend = length = (int) numDigits;
		while (numDigits--) {
		    int digitOffset;

		    if (useBig && big.used) {
			if (index < big.used && (size_t) shift <
				CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) {
			    bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
			    shift += DIGIT_BIT;
			}
			shift -= numBits;
		    }
		    digitOffset = (int) (bits % base);
		    if (digitOffset > 9) {
			if (ch == 'X') {
			    bytes[numDigits] = 'A' + digitOffset - 10;






|
|


|







 







|

|







2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
....
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
		    bits = uw;
		    while (uw) {
			numDigits++;
			uw /= base;
		    }
#endif
		} else if (useBig && big.used) {
		    int leftover = (big.used * MP_DIGIT_BIT) % numBits;
		    mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);

		    numDigits = 1 +
			    (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
		    while ((mask & big.dp[big.used-1]) == 0) {
			numDigits--;
			mask >>= numBits;
		    }
		    if (numDigits > INT_MAX) {
			msg = overflow;
			errCode = "OVERFLOW";
................................................................................
		bytes = TclGetString(pure);
		toAppend = length = (int) numDigits;
		while (numDigits--) {
		    int digitOffset;

		    if (useBig && big.used) {
			if (index < big.used && (size_t) shift <
				CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
			    bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
			    shift += MP_DIGIT_BIT;
			}
			shift -= numBits;
		    }
		    digitOffset = (int) (bits % base);
		    if (digitOffset > 9) {
			if (ch == 'X') {
			    bytes[numDigits] = 'A' + digitOffset - 10;

Changes to generic/tclStubInit.c.

364
365
366
367
368
369
370


371
372
373
374
375
376
377
#   define Tcl_AddErrorInfo 0
#   undef Tcl_AddObjErrorInfo
#   define Tcl_AddObjErrorInfo 0
#   undef Tcl_Eval
#   define Tcl_Eval 0
#   undef Tcl_GlobalEval
#   define Tcl_GlobalEval 0


#   undef Tcl_SaveResult
#   define Tcl_SaveResult 0
#   undef Tcl_RestoreResult
#   define Tcl_RestoreResult 0
#   undef Tcl_DiscardResult
#   define Tcl_DiscardResult 0
#   undef Tcl_SetResult






>
>







364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
#   define Tcl_AddErrorInfo 0
#   undef Tcl_AddObjErrorInfo
#   define Tcl_AddObjErrorInfo 0
#   undef Tcl_Eval
#   define Tcl_Eval 0
#   undef Tcl_GlobalEval
#   define Tcl_GlobalEval 0
#   undef Tcl_GetStringResult
#   define Tcl_GetStringResult 0
#   undef Tcl_SaveResult
#   define Tcl_SaveResult 0
#   undef Tcl_RestoreResult
#   define Tcl_RestoreResult 0
#   undef Tcl_DiscardResult
#   define Tcl_DiscardResult 0
#   undef Tcl_SetResult

Changes to generic/tclTest.c.

967
968
969
970
971
972
973
974
975


976
977
978
979
980
981
982
....
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
....
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
    TestAsyncHandler *asyncPtr;
    int id = PTR2INT(clientData);
    const char *listArgv[4], *cmd;
    char string[TCL_INTEGER_SPACE];

    Tcl_MutexLock(&asyncTestMutex);
    for (asyncPtr = firstHandler; asyncPtr != NULL;
         asyncPtr = asyncPtr->nextPtr) {
        if (asyncPtr->id == id) break;


    }
    Tcl_MutexUnlock(&asyncTestMutex);

    if (!asyncPtr) {
        /* Woops - this one was deleted between the AsyncMark and now */
        return TCL_OK;
    }
................................................................................
	TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
	TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
	TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
	TCL_LINK_BINARY
    };
    int optionIndex, typeIndex, readonly, i, size, length;
    char *name, *arg;
    long addr;                  /* Wrong on Windows, but that's MS's fault for
                                 * not supporting <stdint.h> correctly. They
                                 * can suffer the warnings; the rest of us
                                 * shouldn't have to! */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option args");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
	    &optionIndex) != TCL_OK) {
................................................................................
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetLongFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, (void *) addr,
		LinkTypes[typeIndex] | readonly, size);
    }
    return TCL_OK;

  wrongArgs:
    Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
    return TCL_ERROR;






|
|
>
>







 







|
<
<
<







 







|







|







967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
....
3323
3324
3325
3326
3327
3328
3329
3330



3331
3332
3333
3334
3335
3336
3337
....
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
    TestAsyncHandler *asyncPtr;
    int id = PTR2INT(clientData);
    const char *listArgv[4], *cmd;
    char string[TCL_INTEGER_SPACE];

    Tcl_MutexLock(&asyncTestMutex);
    for (asyncPtr = firstHandler; asyncPtr != NULL;
            asyncPtr = asyncPtr->nextPtr) {
        if (asyncPtr->id == id) {
            break;
        }
    }
    Tcl_MutexUnlock(&asyncTestMutex);

    if (!asyncPtr) {
        /* Woops - this one was deleted between the AsyncMark and now */
        return TCL_OK;
    }
................................................................................
	TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
	TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
	TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
	TCL_LINK_BINARY
    };
    int optionIndex, typeIndex, readonly, i, size, length;
    char *name, *arg;
    Tcl_WideInt addr;




    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option args");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
	    &optionIndex) != TCL_OK) {
................................................................................
	name = Tcl_GetString(objv[i++]);

	/*
	 * If no address is given request one in the underlying function
	 */

	if (i < objc) {
	    if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"wrong address value", -1));
		return TCL_ERROR;
	    }
	} else {
	    addr = 0;
	}
	return Tcl_LinkArray(interp, name, INT2PTR(addr),
		LinkTypes[typeIndex] | readonly, size);
    }
    return TCL_OK;

  wrongArgs:
    Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?");
    return TCL_ERROR;

Changes to generic/tclTimer.c.

306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
....
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
....
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
    memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);

    /*
     * Add the event to the queue in the correct position
     * (ordered by event firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
	    break;
	}
................................................................................
    Interp *iPtr = (Interp *) interp;

    Tcl_Time endTime, now;
    Tcl_WideInt diff;

    Tcl_GetTime(&now);
    endTime = now;
    endTime.sec += (long)(ms/1000);
    endTime.usec += ((int)(ms%1000))*1000;
    if (endTime.usec >= 1000000) {
	endTime.sec++;
	endTime.usec -= 1000000;
    }

    do {
	if (Tcl_AsyncReady()) {
................................................................................
	}
	if (iPtr->limit.timeEvent == NULL
		|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
	    diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
		diff = 1;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);
		if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
		    break;
		}
	    } else {
		break;
	    }
	} else {
	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);






|
|







 







|
|







 







|
|
|

|
|
|
|

|
|







306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
....
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
....
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
    memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);

    /*
     * Add the event to the queue in the correct position (ordered by event
     * firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
	    break;
	}
................................................................................
    Interp *iPtr = (Interp *) interp;

    Tcl_Time endTime, now;
    Tcl_WideInt diff;

    Tcl_GetTime(&now);
    endTime = now;
    endTime.sec += (long)(ms / 1000);
    endTime.usec += ((int)(ms % 1000)) * 1000;
    if (endTime.usec >= 1000000) {
	endTime.sec++;
	endTime.usec -= 1000000;
    }

    do {
	if (Tcl_AsyncReady()) {
................................................................................
	}
	if (iPtr->limit.timeEvent == NULL
		|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
	    diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
            if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
                diff = 1;
            }
	    if (diff > 0) {
		Tcl_Sleep((long) diff);
                if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
                    break;
                }
	    } else {
                break;
            }
	} else {
	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);

Changes to generic/tclTomMath.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
111
112
113
114
115
116
117
118



119
120
121
122

123
124
125

126

127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148


149
150
151
152
153
154
155
156







































157
158
159
160
161
162
163
...
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
/* LibTomMath, multiple-precision integer library -- Tom St Denis
 *
 * LibTomMath is a library that provides multiple-precision
 * integer arithmetic as well as number theoretic functionality.
 *
 * The library was designed directly after the MPI library by
 * Michael Fromberger but has been written from scratch with
 * additional optimizations in place.
 *
 * SPDX-License-Identifier: Unlicense
 */
#ifndef BN_H_
#define BN_H_

#include "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif
................................................................................
#   define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1))  /* bits per digit */
#endif

#define MP_DIGIT_BIT     DIGIT_BIT
#define MP_MASK          ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX     MP_MASK

/* equalities */



#define MP_LT        -1   /* less than */
#define MP_EQ         0   /* equal to */
#define MP_GT         1   /* greater than */


#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */


#define MP_OKAY       0   /* ok result */

#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL
#define MP_ITER       -4  /* Max. iterations reached */

#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
#define LTM_PRIME_2MSB_ON  0x0008 /* force 2nd MSB to 1 */

typedef int           mp_err;

/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */

/* default precision */
#ifndef MP_PREC
#   ifndef MP_LOW_MEM
#      define MP_PREC 32        /* default digits of precision */


#   else
#      define MP_PREC 8         /* default digits of precision */
#   endif
#endif

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))








































/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
typedef struct mp_int mp_int;
#endif
struct mp_int {
   int used, alloc, sign;
................................................................................
   mp_digit *dp;
};

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);


#define USED(m)     ((m)->used)
#define DIGIT(m, k) ((m)->dp[(k)])
#define SIGN(m)     ((m)->sign)

/* error code to char* string */
const char *mp_error_to_string(int code);

/* ---> init and deinit bignum functions <--- */
/* init a bignum */
/*
int mp_init(mp_int *a);
|
|
<
<
|
<
<
<
<
<
<







 







|
>
>
>



<
>
|
|
<
>

>





<
<
<





|








>
>








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<







1
2


3






4
5
6
7
8
9
10
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116

117
118
119

120
121
122
123
124
125
126
127



128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
...
198
199
200
201
202
203
204




205
206
207
208
209
210
211
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */









#ifndef BN_H_
#define BN_H_

#include "tclTomMathDecls.h"
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif
................................................................................
#   define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1))  /* bits per digit */
#endif

#define MP_DIGIT_BIT     DIGIT_BIT
#define MP_MASK          ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX     MP_MASK

typedef int mp_sign;
#define MP_ZPOS       0   /* positive integer */
#define MP_NEG        1   /* negative */
typedef int mp_ord;
#define MP_LT        -1   /* less than */
#define MP_EQ         0   /* equal to */
#define MP_GT         1   /* greater than */

typedef int mp_bool;
#define MP_YES        1   /* yes response */
#define MP_NO         0   /* no response */

typedef int mp_err;
#define MP_OKAY       0   /* ok result */
#define MP_ERR        -1  /* unknown error */
#define MP_MEM        -2  /* out of mem */
#define MP_VAL        -3  /* invalid input */
#define MP_RANGE      MP_VAL
#define MP_ITER       -4  /* Max. iterations reached */




/* Primality generation flags */
#define LTM_PRIME_BBS      0x0001 /* BBS style prime */
#define LTM_PRIME_SAFE     0x0002 /* Safe prime (p-1)/2 == prime */
#define LTM_PRIME_2MSB_ON  0x0008 /* force 2nd MSB to 1 */

/* tunable cutoffs */

/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */

/* default precision */
#ifndef MP_PREC
#   ifndef MP_LOW_MEM
#      define MP_PREC 32        /* default digits of precision */
#   elif defined(MP_8BIT)
#      define MP_PREC 16        /* default digits of precision */
#   else
#      define MP_PREC 8         /* default digits of precision */
#   endif
#endif

/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define MP_WARRAY               (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))

/*
 * MP_WUR - warn unused result
 * ---------------------------
 *
 * The result of functions annotated with MP_WUR must be
 * checked and cannot be ignored.
 *
 * Most functions in libtommath return an error code.
 * This error code must be checked in order to prevent crashes or invalid
 * results.
 *
 * If you still want to avoid the error checks for quick and dirty programs
 * without robustness guarantees, you can `#define MP_WUR` before including
 * tommath.h, disabling the warnings.
 */
#ifndef MP_WUR
#  if defined(__GNUC__) && __GNUC__ >= 4
#     define MP_WUR __attribute__((warn_unused_result))
#  else
#     define MP_WUR
#  endif
#endif

#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
#  define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
#  define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
#  define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
#elif defined(_MSC_VER) && _MSC_VER >= 1500
#  define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
#  define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
#else
#  define MP_DEPRECATED
#  define MP_DEPRECATED_PRAGMA(s)
#endif

#define USED(m)    ((m)->used)
#define DIGIT(m,k) ((m)->dp[(k)])
#define SIGN(m)    ((m)->sign)

/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
typedef struct mp_int mp_int;
#endif
struct mp_int {
   int used, alloc, sign;
................................................................................
   mp_digit *dp;
};

/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);






/* error code to char* string */
const char *mp_error_to_string(int code);

/* ---> init and deinit bignum functions <--- */
/* init a bignum */
/*
int mp_init(mp_int *a);

Changes to generic/tclTomMathDecls.h.

41
42
43
44
45
46
47

48

49

50
51
52
53
54
55
56
..
75
76
77
78
79
80
81

82

83
84
85
86
87
88
89
...
104
105
106
107
108
109
110

111

112
113
114
115
116
117
118
#define XFREE(mem, size)                TclBNFree(mem)
#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)


/* Rename the global symbols in libtommath to avoid linkage conflicts */

#define bn_reverse TclBN_reverse

#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs

#define fast_s_mp_sqr TclBN_fast_s_mp_sqr

#define mp_add TclBN_mp_add
#define mp_add_d TclBN_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
................................................................................
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_mp_init_set
#define mp_init_set_int TclBN_mp_init_set_int
#define mp_init_size TclBN_mp_init_size
#define mp_karatsuba_mul TclBN_mp_karatsuba_mul

#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr

#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
#define mp_mul_d TclBN_mp_mul_d
................................................................................
#define mp_tc_and TclBN_mp_tc_and
#define mp_tc_div_2d TclBN_mp_tc_div_2d
#define mp_tc_or TclBN_mp_tc_or
#define mp_tc_xor TclBN_mp_tc_xor
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul

#define mp_toom_sqr TclBN_mp_toom_sqr

#define mp_toradix_n TclBN_mp_toradix_n
#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
#define s_mp_mul_digs TclBN_s_mp_mul_digs
#define s_mp_sqr TclBN_s_mp_sqr






>

>

>







 







>

>







 







>

>







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
..
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
...
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
#define XFREE(mem, size)                TclBNFree(mem)
#define XREALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)


/* Rename the global symbols in libtommath to avoid linkage conflicts */

#define bn_reverse TclBN_reverse
#define s_mp_reverse TclBN_reverse
#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define s_mp_sqr_fast TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
................................................................................
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_mp_init_set
#define mp_init_set_int TclBN_mp_init_set_int
#define mp_init_size TclBN_mp_init_size
#define mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
#define mp_mul_d TclBN_mp_mul_d
................................................................................
#define mp_tc_and TclBN_mp_tc_and
#define mp_tc_div_2d TclBN_mp_tc_div_2d
#define mp_tc_or TclBN_mp_tc_or
#define mp_tc_xor TclBN_mp_tc_xor
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
#define s_mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
#define s_mp_mul_digs TclBN_s_mp_mul_digs
#define s_mp_sqr TclBN_s_mp_sqr

Changes to generic/tclZipfs.c.

377
378
379
380
381
382
383

384
385
386
387
388
389
390
....
1282
1283
1284
1285
1286
1287
1288

1289
1290
1291
1292
1293
1294
1295
....
1675
1676
1677
1678
1679
1680
1681

1682
1683
1684






1685
1686
1687
1688
1689
1690
1691
....
1840
1841
1842
1843
1844
1845
1846

1847
1848
1849
1850
1851
1852
1853
....
4832
4833
4834
4835
4836
4837
4838











4839
4840
4841
4842
4843
4844
4845
static int		ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index,
			    Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
static int		ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
			    Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
static int		ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);

static void		ZipfsSetup(void);
static int		ZipChannelClose(void *instanceData,
			    Tcl_Interp *interp);
static int		ZipChannelGetFile(void *instanceData,
			    int direction, void **handlePtr);
static int		ZipChannelRead(void *instanceData, char *buf,
			    int toRead, int *errloc);
................................................................................
	ZipFSCloseArchive(interp, zf0);
	return TCL_ERROR;
    }
    Unlock();

    *zf = *zf0;
    zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);

    zf->mountPointLen = strlen(zf->mountPoint);
    zf->nameLength = strlen(zipname);
    zf->name = ckalloc(zf->nameLength + 1);
    memcpy(zf->name, zipname, zf->nameLength + 1);
    zf->entries = NULL;
    zf->topEnts = NULL;
    zf->numOpen = 0;
................................................................................
	if (interp) {
	    Tcl_AppendResult(interp, "out of memory", (char *) NULL);
	    Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
	}
	return TCL_ERROR;
    }
    if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {

	return TCL_ERROR;
    }
    return ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname);






}
 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_MountBuffer --
 *
................................................................................
	}
	if (z->data) {
	    ckfree(z->data);
	}
	ckfree(z);
    }
    ZipFSCloseArchive(interp, zf);

    ckfree(zf);
    unmounted = 1;
  done:
    Unlock();
    if (unmounted) {
	Tcl_FSMountsChanged(NULL);
    }
................................................................................
    if (found == 0) {
	zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
	return TCL_OK;
    }

    return TCL_ERROR;
}











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






>







 







>







 







>


|
>
>
>
>
>
>







 







>







 







>
>
>
>
>
>
>
>
>
>
>







377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
....
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
....
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
....
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
....
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
static int		ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index,
			    Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
static int		ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index,
			    Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
static int		ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
			    Tcl_LoadHandle *loadHandle,
			    Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
static void		ZipfsExitHandler(ClientData clientData);
static void		ZipfsSetup(void);
static int		ZipChannelClose(void *instanceData,
			    Tcl_Interp *interp);
static int		ZipChannelGetFile(void *instanceData,
			    int direction, void **handlePtr);
static int		ZipChannelRead(void *instanceData, char *buf,
			    int toRead, int *errloc);
................................................................................
	ZipFSCloseArchive(interp, zf0);
	return TCL_ERROR;
    }
    Unlock();

    *zf = *zf0;
    zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
    Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf);
    zf->mountPointLen = strlen(zf->mountPoint);
    zf->nameLength = strlen(zipname);
    zf->name = ckalloc(zf->nameLength + 1);
    memcpy(zf->name, zipname, zf->nameLength + 1);
    zf->entries = NULL;
    zf->topEnts = NULL;
    zf->numOpen = 0;
................................................................................
	if (interp) {
	    Tcl_AppendResult(interp, "out of memory", (char *) NULL);
	    Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
	}
	return TCL_ERROR;
    }
    if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
	ckfree(zf);
	return TCL_ERROR;
    }
    if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
	    != TCL_OK) {
	ckfree(zf);
	return TCL_ERROR;
    }
    ckfree(zf);
    return TCL_OK;
}
 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_MountBuffer --
 *
................................................................................
	}
	if (z->data) {
	    ckfree(z->data);
	}
	ckfree(z);
    }
    ZipFSCloseArchive(interp, zf);
    Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf);
    ckfree(zf);
    unmounted = 1;
  done:
    Unlock();
    if (unmounted) {
	Tcl_FSMountsChanged(NULL);
    }
................................................................................
    if (found == 0) {
	zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
	return TCL_OK;
    }

    return TCL_ERROR;
}
 
static void
ZipfsExitHandler(
    ClientData clientData)
{
    ZipFile *zf = (ZipFile *)clientData;

    if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) {
	Tcl_Panic("tried to unmount busy filesystem");
    }
}
 
/*
 *-------------------------------------------------------------------------
 *
 * TclZipfs_AppHook --
 *
 *	Performs the argument munging for the shell

Changes to library/msgs/ja.msg.

36
37
38
39
40
41
42
43
44
    ::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
    ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
    ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
    ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988}"
}






|

36
37
38
39
40
41
42
43
44
    ::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
    ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
    ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
    ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
}

Changes to tests/basic.test.

959
960
961
962
963
964
965












966
967
968
969
970
971
972
} -result {0 10 1 Hejsan}

test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
    unset -nocomplain a
} -body {
    run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}













} ;# End of noComp loop

test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace






>
>
>
>
>
>
>
>
>
>
>
>







959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
} -result {0 10 1 Hejsan}

test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
    unset -nocomplain a
} -body {
    run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}

test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
    unset -nocomplain ::CRLF
    set ::CRLF "\r\n"
} -body {
    # Force variant that turned up in Bug 2c154a40be as that's externally
    # noticeable in an important downstream project.
    run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
    unset -nocomplain ::CRLF
} -result {120 {} {}}


} ;# End of noComp loop

test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace

Changes to tests/clock.test.

36703
36704
36705
36706
36707
36708
36709
36710
36711
36712
36713
36714
36715
36716
36717
36718


36719
36720
36721
36722
36723
36724
36725
36726
		}
	    }
	    return $retval
	}
    }
    -body {
	set trouble {}
	foreach {date jdate} [list \
	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \
	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \
	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \
	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \
	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \
	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \
	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \
	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \


	] {
	    set status [catch {
		set secs [clock scan $date \
			      -timezone +0900 \
			      -locale ja_JP \
			      -format %Y-%m-%d]
		set jda [clock format $secs \
			     -timezone +0900 \






|
|
|
|
|
|
|
|
|
>
>
|







36703
36704
36705
36706
36707
36708
36709
36710
36711
36712
36713
36714
36715
36716
36717
36718
36719
36720
36721
36722
36723
36724
36725
36726
36727
36728
		}
	    }
	    return $retval
	}
    }
    -body {
	set trouble {}
	foreach {date jdate} {
	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
	    2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
	    2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
	} {
	    set status [catch {
		set secs [clock scan $date \
			      -timezone +0900 \
			      -locale ja_JP \
			      -format %Y-%m-%d]
		set jda [clock format $secs \
			     -timezone +0900 \

Changes to tests/cmdMZ.test.

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after" 
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {after 0}
}







|







312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test

# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
    set usec [expr {$msec * 1000}]
    set stime [clock microseconds]
    while {abs([clock microseconds] - $stime) < $usec} {after 0}
}

Changes to tests/coroutine.test.

788
789
790
791
792
793
794











































































795
796
797
798
799
800
801
802
803
804
    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}











































































 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}

test coroutine-9.1 {coro type} {
    coroutine demo eval {
	yield
	yield "PHASE 1"
	yieldto string cat "PHASE 2"
	::tcl::unsupported::corotype [info coroutine]
    }
    list [demo] [::tcl::unsupported::corotype demo] \
	[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-9.2 {coro type} -setup {
    catch {rename nosuchcommand ""}
} -returnCodes error -body {
    ::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-9.3 {coro type} -returnCodes error -body {
    proc notacoroutine {} {}
    ::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
    rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}

test coroutine-10.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {type var} {
	    upvar 1 $var v
	    set f [info frame]
	    incr f -1
	    set result [list $v [dict get [info frame $f] proc]]
	    if {$type eq "yield"} {
		tailcall yield $result
	    } else {
		tailcall yieldto string cat $result
	    }
	}
	proc pokecoro {c var} {
	    inject $c probe [corotype $c] $var
	    $c
	}

	# Coroutine implementations
	proc cbody1 {} {
	    set val [info coroutine]
	    set accum {}
	    while {[set val [yield $val]] ne ""} {
		lappend accum $val
		set val ok
	    }
	    return $accum
	}
	proc cbody2 {} {
	    set val [info coroutine]
	    set accum {}
	    while {[llength [set val [yieldto string cat $val]]]} {
		lappend accum {*}$val
		set val ok
	    }
	    return $accum
	}

	# Make the coroutines
	coroutine c1 cbody1
	coroutine c2 cbody2
	list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
	    [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
	    [c1] [c2]
    }
} -cleanup {
    interp delete $i
} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:

Changes to tests/dict.test.

2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
....
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
    dict getwithdefault {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
    dict getwithdefault {} {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-26.10 {dict getdef command} -returnCodes error -body {
    dict getwithdefault {a b c} d e
} -result {missing value to go with key}
test dict-27.11 {dict getwithdefault command} -body {
    $dict getwithdefault {a b} a c
} -result b
test dict-27.12 {dict getwithdefault command} -body {
    $dict getwithdefault {a b} b c
................................................................................
} -result d
test dict-27.15 {dict getwithdefault command} -body {
    $dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
    $dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-26.17 {dict getdef command} -returnCodes error -body {
    $dict getwithdefault {a b c} d e
} -result {missing value to go with key}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






|







 







|










2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
....
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
    dict getwithdefault {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
    dict getwithdefault {} {}
} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
test dict-27.10 {dict getdef command} -returnCodes error -body {
    dict getwithdefault {a b c} d e
} -result {missing value to go with key}
test dict-27.11 {dict getwithdefault command} -body {
    $dict getwithdefault {a b} a c
} -result b
test dict-27.12 {dict getwithdefault command} -body {
    $dict getwithdefault {a b} b c
................................................................................
} -result d
test dict-27.15 {dict getwithdefault command} -body {
    $dict getwithdefault {a {b c}} b c d
} -result d
test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
    $dict getwithdefault {a {b c d}} a b d
} -result {missing value to go with key}
test dict-27.17 {dict getdef command} -returnCodes error -body {
    $dict getwithdefault {a b c} d e
} -result {missing value to go with key}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/io.test.

5959
5960
5961
5962
5963
5964
5965































































5966
5967
5968
5969
5970
5971
5972
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    close $f4
    set x
} {initial foo eof}

close $f































































makeFile "foo bar" foo

test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
    set f [open $path(foo) r]
    fileevent $f readable [namespace code {
	lappend x "binding triggered: \"[gets $f]\""
	fileevent $f readable {}






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    close $f4
    set x
} {initial foo eof}

close $f

test chan-io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio unixExecs fileevent openpipe} -body {

    namespace eval refchan {
	namespace ensemble create
	namespace export *


	proc finalize {chan args} {
	    namespace delete c_$chan
	}

	proc initialize {chan args} {
	    namespace eval c_$chan {}
	    namespace upvar c_$chan watching watching
	    set watching {}
	    list finalize initialize seek watch write
	}


	proc watch {chan args} {
	    namespace upvar c_$chan watching watching
	    foreach arg $args {
		switch $arg {
		    write {
			if {$arg ni $watching} {
			    lappend watching $arg
			}
			chan postevent $chan $arg
		    }
		}
	    }
	}


	proc write {chan args} {
	    chan postevent $chan write
	    return 1
	}
    }
    set f [chan create w [namespace which refchan]]
    chan configure $f -blocking 0
    set data "some data"
    set x 0
    chan event $f writable [namespace code {
	puts $f $data
	incr count [string length $data]
	if {$count > 262144} {
	    chan event $f writable {}
	    set x done
	}
    }]
    after 10000 [namespace code {
	set x timeout
    }]
    vwait [namespace which -variable x]
    return $x
} -cleanup {
    catch {chan close $f}
} -result done


makeFile "foo bar" foo

test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
    set f [open $path(foo) r]
    fileevent $f readable [namespace code {
	lappend x "binding triggered: \"[gets $f]\""
	fileevent $f readable {}

Changes to tests/ioCmd.test.

2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
    chan postevent $c read
} -cleanup {
    rename foo   {}
    rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
    chan postevent
    
    call to current coroutine

    see 67a5eabbd3d1
} -match glob -body {
    set res {}
    proc foo {args} {oninit; onwatch; onfinal; track; return}
    set c [chan create {r w} foo]






|







2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
    chan postevent $c read
} -cleanup {
    rename foo   {}
    rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
    chan postevent

    call to current coroutine

    see 67a5eabbd3d1
} -match glob -body {
    set res {}
    proc foo {args} {oninit; onwatch; onfinal; track; return}
    set c [chan create {r w} foo]

Changes to tests/link.test.

21
22
23
24
25
26
27










28
29
30
31
32
33
34
testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]

foreach i {int real bool string} {
    unset -nocomplain $i
}










 
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list $int $real $bool $string $wide






>
>
>
>
>
>
>
>
>
>







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]

foreach i {int real bool string} {
    unset -nocomplain $i
}
 
test link-0.1 {leak test} {testlink} {
    interp create i
    load {} Tcltest i
    i eval {
	testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
	namespace delete ::
    }
    interp delete i
} {}
 
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list $int $real $bool $string $wide

Changes to tests/upvar.test.

352
353
354
355
356
357
358




359
360
361
362
363
364
365
    array set upvarArray {}
    upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *

test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
    list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}




test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
    catch {unset a}
    catch {unset x}
    set a 44
    list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {






>
>
>
>







352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
    array set upvarArray {}
    upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *

test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
    list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "xyz"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
    apply {{} {testupvar xyz a {} x local; set x foo}}
    set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
    catch {unset a}
    catch {unset x}
    set a 44
    list [catch "testupvar #0 a 1 x global" msg] $msg
} {1 {can't access "a(1)": variable isn't array}}
test upvar-9.3 {Tcl_UpVar2 procedure} testupvar {

Changes to unix/Makefile.in.

681
682
683
684
685
686
687
688
689
690
691
692
693
694

695

696
697

698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
....
2084
2085
2086
2087
2088
2089
2090
2091
2092

2093
2094
2095
2096
2097
2098
2099
....
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
....
2121
2122
2123
2124
2125
2126
2127

2128
2129
2130
2131
2132

2133
2134
2135


2136
2137
2138
2139
2140
2141
2142
....
2151
2152
2153
2154
2155
2156
2157
2158

2159
2160
2161
2162
2163
2164
2165
....
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
tclzipfile: ${TCL_ZIP_FILE}

${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
	@rm -rf ${TCL_VFS_ROOT}
	@mkdir -p ${TCL_VFS_PATH}
	@echo "creating ${TCL_VFS_PATH} (prepare compression)"
	@( \
	  ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \
	  ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl \
	) || ( \
	  cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
	  cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
	)

	@find ${TCL_VFS_ROOT} -type d -empty -delete

	(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}') 2>/dev/null || \
	  (echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")`; \

	  cd ${TCL_VFS_ROOT} && \
	  $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
	  echo "${TCL_ZIP_FILE} successful created with $$zip" && \
	  cd ..)

# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
	rm -f [email protected]
	@[email protected]
	@if test "${ZIPFS_BUILD}" = "1" ; then \
		cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
		${NATIVE_ZIP} -A ${LIB_FILE} \
		  || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
	fi

${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
	@if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
	    ( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \
	fi
	rm -f [email protected]
................................................................................
#
# Target to check that all public APIs which are not command implementations
# have an entry in section three of the distributed manpages.
#

checkdoc: $(TCL_LIB_FILE)
	[email protected] i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
		| grep -v 'Cmd$$' | sort -n` ; do \
	    match=0; \

	    for j in $(TOP_DIR)/doc/*.3 ; do \
		if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \
		    match=1; \
		fi; \
	    done; \
	    if [ $$match -eq 0 ] ; then \
		echo $$i; \
................................................................................
	done

#
# Target to check for proper usage of UCHAR macro.
#

checkuchar:
	-egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR

#
# Target to make sure that only symbols with "Tcl" prefixes are exported.
#

checkexports: $(TCL_LIB_FILE)
	[email protected] -p $(TCL_LIB_FILE) \
................................................................................
#--------------------------------------------------------------------------

#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#


rpm: all
	[email protected] -f THIS.TCL.SPEC
	echo "%define _builddir `pwd`" > THIS.TCL.SPEC
	echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
	cat tcl.spec >> THIS.TCL.SPEC

	mkdir -p RPMS/i386
	rpmbuild -bb THIS.TCL.SPEC
	mv RPMS/i386/*.rpm .


	-rm -rf RPMS THIS.TCL.SPEC

#
# Target to create a proper Tcl distribution from information in the master
# source directory. DISTDIR must be defined to indicate where to put the
# distribution. DISTDIR must be an absolute path name.
#
................................................................................
		$(UNIX_DIR)/aclocal.m4
	cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
	cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
	cd $(MAC_OSX_DIR); autoheader; touch [email protected]

dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}

	rm -rf $(DISTDIR)
	mkdir -p $(DISTDIR)/unix
	cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
	cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
	chmod 664 $(DISTDIR)/unix/Makefile.in
	cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.ac \
		$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
................................................................................
	cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
	cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \
		$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
		$(DISTDIR)
	@mkdir $(DISTDIR)/library
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
		$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
	for i in $(BUILTIN_PACKAGE_LIST) ; do \
	    mkdir $(DISTDIR)/library/$$i;\
	    cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
	done
	@mkdir $(DISTDIR)/library/encoding
	cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
	@mkdir $(DISTDIR)/library/msgs
	cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
	@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
	@( cd $(TOP_DIR); \
	  find library/tzdata -name CVS -prune -o -type f -print ) \
	    | ( cd $(TOP_DIR) ; xargs tar cf - ) \
	    | ( cd $(DISTDIR) ; tar xfp - )
	@mkdir $(DISTDIR)/doc
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
		$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
	@mkdir $(DISTDIR)/compat
	cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
		$(COMPAT_DIR)/README $(DISTDIR)/compat
	@mkdir $(DISTDIR)/compat/zlib
	( cd $(COMPAT_DIR)/zlib; \
	  find . -name CVS -prune -o -type f -print ) \
	    | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
	    | ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
	@mkdir $(DISTDIR)/tests
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
	cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
		$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
		$(DISTDIR)/tests






|
|
|
|
|
|
<
>

>
|
|
>
|
|
<
<







|
|
|







 







|

>







 







|







 







>





>
|
|
<
>
>







 







|
>







 







|








|
<









|
|







681
682
683
684
685
686
687
688
689
690
691
692
693

694
695
696
697
698
699
700
701


702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
....
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
....
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
....
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137

2138
2139
2140
2141
2142
2143
2144
2145
2146
....
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
....
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198

2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
tclzipfile: ${TCL_ZIP_FILE}

${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
	@rm -rf ${TCL_VFS_ROOT}
	@mkdir -p ${TCL_VFS_PATH}
	@echo "creating ${TCL_VFS_PATH} (prepare compression)"
	@if \
	    ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/ && \
	    ln ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \
	then : ; else \
	    cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
	    cp -a ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl; \

	fi
	@find ${TCL_VFS_ROOT} -type d -empty -delete
	@echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}"
	@(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \
	    echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?")  2>/dev/null`; \
	    echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \
	    cd ${TCL_VFS_ROOT} && \
	    $$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null)



# The following target is configured by autoconf to generate either a shared
# library or non-shared library for Tcl.
${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE}
	rm -f [email protected]
	@[email protected]
	@if test "${ZIPFS_BUILD}" = "1" ; then \
	    cat ${TCL_ZIP_FILE} >> ${LIB_FILE}; \
	    ${NATIVE_ZIP} -A ${LIB_FILE} \
	    || echo 'ignore zip-error by adjust sfx process (not executable?)'; \
	fi

${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
	@if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \
	    ( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \
	fi
	rm -f [email protected]
................................................................................
#
# Target to check that all public APIs which are not command implementations
# have an entry in section three of the distributed manpages.
#

checkdoc: $(TCL_LIB_FILE)
	[email protected] i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
		| grep -Fv . | grep -v 'Cmd$$' | sort -n` ; do \
	    match=0; \
	    i=`echo $$i | sed 's/^_//'`; \
	    for j in $(TOP_DIR)/doc/*.3 ; do \
		if [ `grep '\-' $$j | grep -c $$i` -gt 0 ] ; then \
		    match=1; \
		fi; \
	    done; \
	    if [ $$match -eq 0 ] ; then \
		echo $$i; \
................................................................................
	done

#
# Target to check for proper usage of UCHAR macro.
#

checkuchar:
	-@egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR

#
# Target to make sure that only symbols with "Tcl" prefixes are exported.
#

checkexports: $(TCL_LIB_FILE)
	[email protected] -p $(TCL_LIB_FILE) \
................................................................................
#--------------------------------------------------------------------------

#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#

RPM_PLATFORMS = i386
rpm: all
	[email protected] -f THIS.TCL.SPEC
	echo "%define _builddir `pwd`" > THIS.TCL.SPEC
	echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
	cat tcl.spec >> THIS.TCL.SPEC
	for platform in $(RPM_PLATFORMS); do \
	    mkdir -p RPMS/$$platform && \
	    rpmbuild -bb THIS.TCL.SPEC && \

	    mv RPMS/$$platform/*.rpm .; \
	done
	-rm -rf RPMS THIS.TCL.SPEC

#
# Target to create a proper Tcl distribution from information in the master
# source directory. DISTDIR must be defined to indicate where to put the
# distribution. DISTDIR must be an absolute path name.
#
................................................................................
		$(UNIX_DIR)/aclocal.m4
	cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
	cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
	cd $(MAC_OSX_DIR); autoheader; touch [email protected]

dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \
		$(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}
	rm -rf $(DISTDIR)
	mkdir -p $(DISTDIR)/unix
	cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
	cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
	chmod 664 $(DISTDIR)/unix/Makefile.in
	cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.ac \
		$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
................................................................................
	cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
	cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \
		$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
		$(DISTDIR)
	@mkdir $(DISTDIR)/library
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
		$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
	@for i in $(BUILTIN_PACKAGE_LIST) ; do \
	    mkdir $(DISTDIR)/library/$$i;\
	    cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
	done
	@mkdir $(DISTDIR)/library/encoding
	cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
	@mkdir $(DISTDIR)/library/msgs
	cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
	@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
	@( cd $(TOP_DIR); find library/tzdata -type f -print ) \

	    | ( cd $(TOP_DIR) ; xargs tar cf - ) \
	    | ( cd $(DISTDIR) ; tar xfp - )
	@mkdir $(DISTDIR)/doc
	cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
		$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
	@mkdir $(DISTDIR)/compat
	cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
		$(COMPAT_DIR)/README $(DISTDIR)/compat
	@mkdir $(DISTDIR)/compat/zlib
	@echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib
	@( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \
	    | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
	    | ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
	@mkdir $(DISTDIR)/tests
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
	cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
		$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
		$(DISTDIR)/tests

Changes to unix/dltest/Makefile.in.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
DLTEST_SUFFIX =		@[email protected]
SRC_DIR =		@[email protected]/unix/dltest
BUILD_DIR =		@[email protected]
TCL_VERSION=		@[email protected]

CFLAGS_DEBUG		= @[email protected]
CFLAGS_OPTIMIZE		= @[email protected]
CFLAGS			= @[email protected] @[email protected]
LDFLAGS_DEBUG		= @[email protected]
LDFLAGS_OPTIMIZE	= @[email protected]
LDFLAGS			= @[email protected] @[email protected]

CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
	${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
DLTEST_SUFFIX =		@[email protected]
SRC_DIR =		@[email protected]/unix/dltest
BUILD_DIR =		@[email protected]
TCL_VERSION=		@[email protected]

CFLAGS_DEBUG		= @[email protected]
CFLAGS_OPTIMIZE		= @[email protected]
CFLAGS			= @[email protected] @[email protected] -DTCL_NO_DEPRECATED=1
LDFLAGS_DEBUG		= @[email protected]
LDFLAGS_OPTIMIZE	= @[email protected]
LDFLAGS			= @[email protected] @[email protected]

CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
	${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}

Changes to win/tclWinFile.c.

676
677
678
679
680
681
682
683

684
685
686
687
688
689
690
...
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
....
1446
1447
1448
1449
1450
1451
1452

1453


1454
1455
1456

1457


1458
1459
1460
1461
1462
1463
1464
....
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480

1481
1482




1483


1484
1485


1486
1487
1488
1489

1490
1491
1492
1493
1494
1495
1496
1497
1498

1499
1500
1501
1502
1503
1504


1505


1506
1507


1508
1509
1510
1511
1512
1513
1514
....
1588
1589
1590
1591
1592
1593
1594

1595
1596
1597
1598
1599
1600
1601
1602
1603
1604

1605
1606
1607
1608
1609

1610


1611
1612
1613
1614


1615


1616
1617
1618


1619


1620


1621
1622

1623
1624
1625
1626
1627
1628
1629


1630


1631
1632
1633
1634
1635


1636


1637
1638
1639
1640
1641
1642
1643
....
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
....
2028
2029
2030
2031
2032
2033
2034


2035


2036
2037
2038
2039
2040
2041
2042
....
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
....
2539
2540
2541
2542
2543
2544
2545

2546
2547
2548
2549


2550
2551
2552
2553
2554
2555
2556
....
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
....
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
....
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
....
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
....
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
....
2989
2990
2991
2992
2993
2994
2995


2996


2997
2998
2999
3000
3001
3002
3003
3004
3005


3006



3007
3008
3009
3010
3011
3012

3013


3014
3015


3016


3017
3018

3019
3020


3021
3022
3023
3024
3025


3026


3027
3028
3029
3030
3031


3032
3033
3034
3035
3036
3037



3038
3039
3040
3041

3042
3043
3044
3045
3046
3047
3048
3049


3050
3051


3052
3053
3054
3055

3056
3057
3058
3059

3060
3061
3062
3063

3064
3065
3066
3067

3068
3069
3070
3071

3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
....
3201
3202
3203
3204
3205
3206
3207
3208
3209

3210
3211


3212
3213
3214
3215
3216
3217
3218
3219
3220

3221

3222


3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233

3234


3235
3236

3237
3238

3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
    const WCHAR *linkDirPath,	/* The junction to read */
    REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
    DWORD desiredAccess)
{
    HANDLE hFile;
    DWORD returnedLength;

    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING,

	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */

................................................................................
#elif defined(_MSC_VER) && defined (_M_IX86)
    _asm {int 3}
#else
    DebugBreak();
#endif
    abort();
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application.
................................................................................
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;


	/* no domain - firstly check it's the current user */


	if ( (ptr = TclpGetUserName(&ds)) != NULL
	  && strcasecmp(name, ptr) == 0
	) {

	    /* try safest and fastest way to get current user home */


	    ptr = TclGetEnv("HOME", &ds);
	    if (ptr != NULL) {
		Tcl_JoinPath(1, &ptr, bufferPtr);
		rc = 1;
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
................................................................................
	nameLen = domain - name;
    }
    if (rc == 0) {
	Tcl_DStringInit(&ds);
	wName = TclUtfToWCharDString(name, nameLen, &ds);
	while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
	    /*
	     * user does not exists - if domain was not specified,
	     * try again using current domain.
	     */

	    rc = 1;
	    if (domain != NULL) break;




	    /* get current domain */


	    rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
	    if (rc != 0) break;


	    domain = INT2PTR(-1); /* repeat once */
	}
	if (rc == 0) {
	    DWORD i, size = MAX_PATH;

	    wHomeDir = uiPtr->usri1_home_dir;
	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
		size = lstrlenW(wHomeDir);
		TclWCharToUtfDString(wHomeDir, size, bufferPtr);
	    } else {
		/*
		 * User exists but has no home dir. Return
		 * "{GetProfilesDirectory}/<user>".
		 */

		GetProfilesDirectoryW(buf, &size);
		TclWCharToUtfDString(buf, size-1, bufferPtr);
		Tcl_DStringAppend(bufferPtr, "/", 1);
		Tcl_DStringAppend(bufferPtr, name, nameLen);
	    }
	    result = Tcl_DStringValue(bufferPtr);


	    /* be sure we return normalized path */


	    for (i = 0; i < size; ++i){
		if (result[i] == '\\') result[i] = '/';


	    }
	    NetApiBufferFree((void *) uiPtr);
	}
	Tcl_DStringFree(&ds);
    }
    if (wDomain != NULL) {
	NetApiBufferFree((void *) wDomain);
................................................................................

	return 0;
    }

    /*
     * If it's not a directory (assume file), do several fast checks:
     */

    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * If the attributes say this is not writable at all.  The file is a
	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.	 For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks
	 * will be done below.
	 */

	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}


	/* If doesn't have the correct extension, it can't be executable */


	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}


	/* Special case for read/write/executable check on file */


	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
	    DWORD mask = 0;
	    HANDLE hFile;


	    if (mode & R_OK) { mask |= GENERIC_READ;  }


	    if (mode & W_OK) { mask |= GENERIC_WRITE; }


	    if (mode & X_OK) { mask |= GENERIC_EXECUTE; }


	    hFile = CreateFile(nativePath, mask,
		FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
		OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
	    if (hFile != INVALID_HANDLE_VALUE) {
		CloseHandle(hFile);
		return 0;
	    }


	    /* fast exit if access was denied */


	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}


	/* We cannnot verify the access fast, check it below using security info. */


    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hardcoded names
     * like CON, NULL, COM1, LPT1 etc. For these, we still need to
     * do the CreateFile as some may not exist (e.g. there is no CON
     * in wish by default). However the subsequent GetFileInformationByHandle
     * will fail. We do a WinIsReserved to see if it is one of the special
     * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION
     * structure.
     */

    fileHandle = CreateFile(nativePath, GENERIC_READ,
	    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

................................................................................
	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
            fileType = GetFileType(fileHandle);
            CloseHandle(fileHandle);
            if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
                Tcl_SetErrno(ENOENT);
                return -1;
            }


            /* Mock up the expected structure */


            memset(&data, 0, sizeof(data));
            statPtr->st_atime = 0;
            statPtr->st_mtime = 0;
            statPtr->st_ctime = 0;
        } else {
            CloseHandle(fileHandle);
            statPtr->st_atime = ToCTime(data.ftLastAccessTime);
................................................................................

    if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
	if (wcscmp((const WCHAR*)clientData, buffer) == 0) {
	    return clientData;
	}
    }

    return TclNativeDupInternalRep(buffer);
}
 
................................................................................
			    }
			}
			Tcl_DStringAppend(&dsNorm,
				(const char *)nativePath,
				(int)(sizeof(WCHAR) * len));
			lastValidPathEnd = currentPathEndPosition;
		    } else if (nextCheckpoint == 0) {

			/* Path starts with a drive designation
			 * that's not actually on the system.
			 * We still must normalize up past the
			 * first separator.  [Bug 3603434] */


			currentPathEndPosition++;
		    }
		}
		Tcl_DStringFree(&ds);
		break;
	    }

................................................................................
	    /*
	     * File 'nativePath' does exist if we get here. We now want to
	     * check if it is a symlink and otherwise continue with the
	     * rest of the path.
	     */

	    /*
	     * Check for symlinks, except at last component of path (we
	     * don't follow final symlinks). Also a drive (C:/) for
	     * example, may sometimes have the reparse flag set for some
	     * reason I don't understand. We therefore don't perform this
	     * check for drives.
	     */

	    if (cur != 0 && !isDrive &&
		    data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
		Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		if (to != NULL) {
		    /*
		     * Read the reparse point ok. Now, reparse points need
		     * not be normalized, otherwise we could use:
		     *
		     * Tcl_GetStringFromObj(to, &pathLen);
		     * nextCheckpoint = pathLen;
		     *
		     * So, instead we have to start from the beginning.
		     */

................................................................................
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH
	    /*
	     * Now we convert the tail of the current path to its 'long
	     * form', and append it to 'dsNorm' which holds the current
	     * normalized path
	     */

	    if (isDrive) {
		WCHAR drive = ((WCHAR *) nativePath)[0];

		if (drive >= L'a') {
		    drive -= (L'a' - L'A');
................................................................................
			checkDots++;
		    }
		}
		if (checkDots != NULL) {
		    int dotLen = currentPathEndPosition-lastValidPathEnd;

		    /*
		     * Path is just dots. We shouldn't really ever see a
		     * path like that. However, to be nice we at least
		     * don't mangle the path - we just add the dots as a
		     * path segment and continue.
		     */

		    Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
			    + Tcl_DStringLength(&ds)
			    - (dotLen * sizeof(WCHAR)),
			    dotLen * sizeof(WCHAR));
		} else {
................................................................................

		    WIN32_FIND_DATAW fData;
		    HANDLE handle;

		    handle = FindFirstFileW((WCHAR *) nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			/*
			 * This is usually the '/' in 'c:/' at end of
			 * string.
			 */

			Tcl_DStringAppend(&dsNorm, (const char *) L"/",
				sizeof(WCHAR));
		    } else {
			WCHAR *nativeName;

................................................................................
	    Tcl_DStringFree(&ds);
	    lastValidPathEnd = currentPathEndPosition;
	    if (cur == 0) {
		break;
	    }

	    /*
	     * If we get here, we've got past one directory delimiter, so
	     * we know it is no longer a drive.
	     */

	    isDrive = 0;
	}
	currentPathEndPosition++;

#ifdef TclNORM_LONG_PATH
................................................................................
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}


	/* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */


    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}


	/* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */



	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);

    if (strlen(str)!=(size_t)len) {

	/* String contains NUL-bytes. This is invalid. */


	goto done;
    }


    /* For a reserved device, strip a possible postfix ':' */


    len = WinIsReserved(str);
    if (len == 0) {

	/* Let MultiByteToWideChar check for other invalid sequences, like
	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */


	len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
	if (len==0) {
	    goto done;
	}
    }


    /* Overallocate 6 chars, making some room for extended paths */


    wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) );
    if (nativePathPtr==0) {
      goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1);


    /*
    ** If path starts with "//?/" or "\\?\" (extended path), translate
    ** any slashes to backslashes but leave the '?' intact
    */
    if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
	    && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {



	wp[0] = wp[1] = wp[3] = '\\';
	str += 4;
	wp += 4;
    }

    /*
    ** If there is no "\\?\" prefix but there is a drive or UNC
    ** path prefix and the path is larger than MAX_PATH chars,
    ** no Win32 API function can handle that unless it is
    ** prefixed with the extended path prefix. See:
    ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
    **/
    if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))


	    && str[1]==':') {
	if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {


	    memmove(wp+4, wp, len*sizeof(WCHAR));
	    memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));
	    wp += 4;
	}

	/*
	 ** If (remainder of) path starts with "<drive>:",
	 ** leave the ':' intact.
	 */

	wp += 2;
    } else if (wp==nativePathPtr && len>MAX_PATH
	    && (str[0]=='\\' || str[0]=='/')
	    && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {

	memmove(wp+6, wp, len*sizeof(WCHAR));
	memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
	wp += 7;
    }

    /*
    ** In the remainder of the path, translate invalid characters to
    ** characters in the Unicode private use area.
    */

    while (*wp != '\0') {
	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
	    *wp |= 0xF000;
	} else if (*wp == '/') {
	    *wp = '\\';
	}
	++wp;
    }

  done:

    TclDecrRefCount(validPathPtr);
    return nativePathPtr;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    LPBYTE buf = NULL;
    DWORD bufsz;
    int owned = 0;

    native = Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
                             OWNER_SECURITY_INFORMATION, &ownerSid,
                             NULL, NULL, NULL, &secd) != ERROR_SUCCESS) {

        /* Either not a file, or we do not have access to it in which
           case we are in all likelihood not the owner */


        return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.
     * We make the assumption that if a call fails, this process is
     * so underprivileged it could not possibly own anything. Normally
     * a process can *always* look up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {

        /* Find out how big the buffer needs to be */


        bufsz = 0;
        GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
        if (bufsz) {
            buf = ckalloc(bufsz);
            if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
                owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
            }
        }
        CloseHandle(token);
    }


    /* Free allocations and be done */


    if (secd)
        LocalFree(secd);            /* Also frees ownerSid */

    if (buf)
        ckfree(buf);


    return (owned != 0);        /* Convert non-0 to 1 */
}

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






|
>







 







|







 







>
|
>
>
|
|
<
>
|
>
>







 







|
|

>

|
>
>
>
>
|
>
>

|
>
>




>









>






>
>
|
>
>
|
|
>
>







 







>




|


|
|

>





>
|
>
>




>
>
|
>
>



>
>
|
>
>
|
>
>
|
|
>

|
|




>
>
|
>
>





>
>
|
>
>







 







|
|
|
|
|
|
<







 







>
>
|
>
>







 







|







 







>
|
<
|
|
>
>







 







|
|
|
|
<








|
|







 







|
|
|







 







|
|
|
|







 







|
<







 







|
|







 







>
>
|
>
>









>
>
|
>
>
>





|
>
|
>
>


>
>
|
>
>


>
|
|
>
>





>
>
|
>
>
|



|
>
>

|
|
|
<
<
>
>
>




>

|
|
<
|
|
|
<
>
>
|
<
>
>
|
|


>

|
|

>

|
|
<
>
|
|


>

|
|
|
>










<







 







|
|
>
|
|
>
>




|
|
|
|

>

>
|
>
>











>
|
>
>
|

>
|

>



|







676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
...
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
....
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459

1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
....
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
....
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
....
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063

2064
2065
2066
2067
2068
2069
2070
....
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
....
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
....
2589
2590
2591
2592
2593
2594
2595
2596
2597

2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
....
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619

2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
....
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
....
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
....
2714
2715
2716
2717
2718
2719
2720
2721

2722
2723
2724
2725
2726
2727
2728
....
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
....
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110


3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121

3122
3123
3124

3125
3126
3127

3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142

3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163

3164
3165
3166
3167
3168
3169
3170
....
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
    const WCHAR *linkDirPath,	/* The junction to read */
    REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
    DWORD desiredAccess)
{
    HANDLE hFile;
    DWORD returnedLength;

    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
	    OPEN_EXISTING,
	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */

................................................................................
#elif defined(_MSC_VER) && defined (_M_IX86)
    _asm {int 3}
#else
    DebugBreak();
#endif
    abort();
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application.
................................................................................
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;

	/*
	 * No domain. Firstly check it's the current user
	 */

	ptr = TclpGetUserName(&ds);
	if (ptr != NULL && strcasecmp(name, ptr) == 0) {

	    /*
	     * Try safest and fastest way to get current user home
	     */

	    ptr = TclGetEnv("HOME", &ds);
	    if (ptr != NULL) {
		Tcl_JoinPath(1, &ptr, bufferPtr);
		rc = 1;
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
................................................................................
	nameLen = domain - name;
    }
    if (rc == 0) {
	Tcl_DStringInit(&ds);
	wName = TclUtfToWCharDString(name, nameLen, &ds);
	while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
	    /*
	     * User does not exist; if domain was not specified, try again
	     * using current domain.
	     */

	    rc = 1;
	    if (domain != NULL) {
		break;
	    }

	    /*
	     * Get current domain
	     */

	    rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
	    if (rc != 0) {
		break;
	    }
	    domain = INT2PTR(-1); /* repeat once */
	}
	if (rc == 0) {
	    DWORD i, size = MAX_PATH;

	    wHomeDir = uiPtr->usri1_home_dir;
	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
		size = lstrlenW(wHomeDir);
		TclWCharToUtfDString(wHomeDir, size, bufferPtr);
	    } else {
		/*
		 * User exists but has no home dir. Return
		 * "{GetProfilesDirectory}/<user>".
		 */

		GetProfilesDirectoryW(buf, &size);
		TclWCharToUtfDString(buf, size-1, bufferPtr);
		Tcl_DStringAppend(bufferPtr, "/", 1);
		Tcl_DStringAppend(bufferPtr, name, nameLen);
	    }
	    result = Tcl_DStringValue(bufferPtr);

	    /*
	     * Be sure we return normalized path
	     */

	    for (i = 0; i < size; ++i) {
		if (result[i] == '\\') {
		    result[i] = '/';
		}
	    }
	    NetApiBufferFree((void *) uiPtr);
	}
	Tcl_DStringFree(&ds);
    }
    if (wDomain != NULL) {
	NetApiBufferFree((void *) wDomain);
................................................................................

	return 0;
    }

    /*
     * If it's not a directory (assume file), do several fast checks:
     */

    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * If the attributes say this is not writable at all.  The file is a
	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.  For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks will be
	 * done below.
	 */

	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}

	/*
	 * If doesn't have the correct extension, it can't be executable
	 */

	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}

	/*
	 * Special case for read/write/executable check on file
	 */

	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
	    DWORD mask = 0;
	    HANDLE hFile;

	    if (mode & R_OK) {
		mask |= GENERIC_READ;
	    }
	    if (mode & W_OK) {
		mask |= GENERIC_WRITE;
	    }
	    if (mode & X_OK) {
		mask |= GENERIC_EXECUTE;
	    }

	    hFile = CreateFile(nativePath, mask,
		    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
		    NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
	    if (hFile != INVALID_HANDLE_VALUE) {
		CloseHandle(hFile);
		return 0;
	    }

	    /*
	     * Fast exit if access was denied
	     */

	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}

	/*
	 * We cannnot verify the access fast, check it below using security
	 * info.
	 */
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hardcoded names like
     * CON, NULL, COM1, LPT1 etc. For these, we still need to do the
     * CreateFile as some may not exist (e.g. there is no CON in wish by
     * default). However the subsequent GetFileInformationByHandle will
     * fail. We do a WinIsReserved to see if it is one of the special names,
     * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.

     */

    fileHandle = CreateFile(nativePath, GENERIC_READ,
	    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

................................................................................
	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
            fileType = GetFileType(fileHandle);
            CloseHandle(fileHandle);
            if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
                Tcl_SetErrno(ENOENT);
                return -1;
            }

            /*
	     * Mock up the expected structure
	     */

            memset(&data, 0, sizeof(data));
            statPtr->st_atime = 0;
            statPtr->st_mtime = 0;
            statPtr->st_ctime = 0;
        } else {
            CloseHandle(fileHandle);
            statPtr->st_atime = ToCTime(data.ftLastAccessTime);
................................................................................

    if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
	if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
	    return clientData;
	}
    }

    return TclNativeDupInternalRep(buffer);
}
 
................................................................................
			    }
			}
			Tcl_DStringAppend(&dsNorm,
				(const char *)nativePath,
				(int)(sizeof(WCHAR) * len));
			lastValidPathEnd = currentPathEndPosition;
		    } else if (nextCheckpoint == 0) {
			/*
			 * Path starts with a drive designation that's not

			 * actually on the system. We still must normalize up
			 * past the first separator. [Bug 3603434]
			 */

			currentPathEndPosition++;
		    }
		}
		Tcl_DStringFree(&ds);
		break;
	    }

................................................................................
	    /*
	     * File 'nativePath' does exist if we get here. We now want to
	     * check if it is a symlink and otherwise continue with the
	     * rest of the path.
	     */

	    /*
	     * Check for symlinks, except at last component of path (we don't
	     * follow final symlinks). Also a drive (C:/) for example, may
	     * sometimes have the reparse flag set for some reason I don't
	     * understand. We therefore don't perform this check for drives.

	     */

	    if (cur != 0 && !isDrive &&
		    data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
		Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		if (to != NULL) {
		    /*
		     * Read the reparse point ok. Now, reparse points need not
		     * be normalized, otherwise we could use:
		     *
		     * Tcl_GetStringFromObj(to, &pathLen);
		     * nextCheckpoint = pathLen;
		     *
		     * So, instead we have to start from the beginning.
		     */

................................................................................
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH
	    /*
	     * Now we convert the tail of the current path to its 'long form',
	     * and append it to 'dsNorm' which holds the current normalized
	     * path
	     */

	    if (isDrive) {
		WCHAR drive = ((WCHAR *) nativePath)[0];

		if (drive >= L'a') {
		    drive -= (L'a' - L'A');
................................................................................
			checkDots++;
		    }
		}
		if (checkDots != NULL) {
		    int dotLen = currentPathEndPosition-lastValidPathEnd;

		    /*
		     * Path is just dots. We shouldn't really ever see a path
		     * like that. However, to be nice we at least don't mangle
		     * the path - we just add the dots as a path segment and
		     * continue.
		     */

		    Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
			    + Tcl_DStringLength(&ds)
			    - (dotLen * sizeof(WCHAR)),
			    dotLen * sizeof(WCHAR));
		} else {
................................................................................

		    WIN32_FIND_DATAW fData;
		    HANDLE handle;

		    handle = FindFirstFileW((WCHAR *) nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			/*
			 * This is usually the '/' in 'c:/' at end of string.

			 */

			Tcl_DStringAppend(&dsNorm, (const char *) L"/",
				sizeof(WCHAR));
		    } else {
			WCHAR *nativeName;

................................................................................
	    Tcl_DStringFree(&ds);
	    lastValidPathEnd = currentPathEndPosition;
	    if (cur == 0) {
		break;
	    }

	    /*
	     * If we get here, we've got past one directory delimiter, so we
	     * know it is no longer a drive.
	     */

	    isDrive = 0;
	}
	currentPathEndPosition++;

#ifdef TclNORM_LONG_PATH
................................................................................
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}

	/*
	 * refCount of validPathPtr was already incremented in
	 * Tcl_FSGetTranslatedPath
	 */
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}

	/*
	 * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
	 * so incr refCount here
	 */

	Tcl_IncrRefCount(validPathPtr);
    }

    str = Tcl_GetStringFromObj(validPathPtr, &len);

    if (strlen(str) != (size_t) len) {
	/*
	 * String contains NUL-bytes. This is invalid.
	 */

	goto done;
    }

    /*
     * For a reserved device, strip a possible postfix ':'
     */

    len = WinIsReserved(str);
    if (len == 0) {
	/*
	 * Let MultiByteToWideChar check for other invalid sequences, like
	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
	 */

	len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
	if (len==0) {
	    goto done;
	}
    }

    /*
     * Overallocate 6 chars, making some room for extended paths
     */

    wp = nativePathPtr = ckalloc((len + 6) * sizeof(WCHAR));
    if (nativePathPtr==0) {
      goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
	    len + 1);

    /*
     * If path starts with "//?/" or "\\?\" (extended path), translate any
     * slashes to backslashes but leave the '?' intact
     */



    if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
	    && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
	wp[0] = wp[1] = wp[3] = '\\';
	str += 4;
	wp += 4;
    }

    /*
     * If there is no "\\?\" prefix but there is a drive or UNC path prefix
     * and the path is larger than MAX_PATH chars, no Win32 API function can

     * handle that unless it is prefixed with the extended path prefix. See:
     * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
     */


    if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
	    && str[1] == ':') {

	if (wp == nativePathPtr && len > MAX_PATH
		&& (str[2] == '\\' || str[2] == '/')) {
	    memmove(wp + 4, wp, len * sizeof(WCHAR));
	    memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
	    wp += 4;
	}

	/*
	 * If (remainder of) path starts with "<drive>:", leave the ':'
	 * intact.
	 */

	wp += 2;
    } else if (wp == nativePathPtr && len > MAX_PATH
	    && (str[0] == '\\' || str[0] == '/')

	    && (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
	memmove(wp + 6, wp, len * sizeof(WCHAR));
	memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
	wp += 7;
    }

    /*
     * In the remainder of the path, translate invalid characters to
     * characters in the Unicode private use area.
     */

    while (*wp != '\0') {
	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
	    *wp |= 0xF000;
	} else if (*wp == '/') {
	    *wp = '\\';
	}
	++wp;
    }

  done:

    TclDecrRefCount(validPathPtr);
    return nativePathPtr;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    LPBYTE buf = NULL;
    DWORD bufsz;
    int owned = 0;

    native = Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
	    OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
	    &secd) != ERROR_SUCCESS) {
        /*
	 * Either not a file, or we do not have access to it in which case we
	 * are in all likelihood not the owner.
	 */

        return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.  We make the
     * assumption that if a call fails, this process is so underprivileged it
     * could not possibly own anything. Normally a process can *always* look
     * up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
        /*
	 * Find out how big the buffer needs to be.
	 */

        bufsz = 0;
        GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
        if (bufsz) {
            buf = ckalloc(bufsz);
            if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
                owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
            }
        }
        CloseHandle(token);
    }

    /*
     * Free allocations and be done.
     */

    if (secd) {
        LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
        ckfree(buf);
    }

    return (owned != 0);        /* Convert non-0 to 1 */
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Changes to win/tclWinPipe.c.

120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
....
1424
1425
1426
1427
1428
1429
1430
1431
1432


1433


1434
1435
1436
1437
1438
1439
1440
....
1441
1442
1443
1444
1445
1446
1447
1448
1449

1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
....
1463
1464
1465
1466
1467
1468
1469
1470
1471

1472

1473


1474
1475
1476

1477


1478
1479
1480

1481
1482
1483
1484
1485

1486

1487
1488
1489
1490
1491

1492


1493
1494


1495
1496
1497

1498


1499
1500

1501



1502
1503
1504
1505
1506
1507
1508
....
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526

1527
1528
1529
1530
1531
1532
1533
....
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562


1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590

1591


1592
1593
1594

1595


1596
1597
1598
1599

1600



1601

1602


1603
1604


1605
1606
1607

1608





1609


1610
1611


1612


1613
1614
1615
1616


1617



1618
1619



1620


1621
1622
1623


1624



1625
1626



1627


1628
1629
1630


1631


1632

1633
1634


1635



1636
1637
1638
1639

1640


1641
1642
1643
1644
1645
1646
1647
....
2171
2172
2173
2174
2175
2176
2177

2178
2179
2180
2181
2182
2183
2184
2185
2186
....
2358
2359
2360
2361
2362
2363
2364

2365
2366
2367
2368
2369
2370
2371
....
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844

2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
....
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
....
3229
3230
3231
3232
3233
3234
3235

3236
3237
3238
3239

3240


3241

3242

3243


3244
3245


3246
3247

3248

3249
3250
3251
3252
3253
3254

3255
3256
3257

3258


3259

3260

3261


3262
3263
3264

3265


3266
3267
3268

3269


3270
3271
3272
3273
3274
3275
3276
....
3292
3293
3294
3295
3296
3297
3298
3299

3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314

3315



3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329

3330

3331
3332
3333
3334
3335
3336
3337
3338
....
3367
3368
3369
3370
3371
3372
3373

3374
3375
3376
3377

3378
3379
3380
3381
3382



3383
3384
3385
3386

3387



3388
3389
3390
3391

3392


3393
3394
3395

3396

3397

3398

3399
3400
3401
3402
3403
3404
3405
3406

3407

3408
3409
3410


3411

3412
3413

3414
3415
3416
3417
3418
3419
3420
....
3421
3422
3423
3424
3425
3426
3427
3428
3429

3430
3431
3432
3433
3434
3435
3436
3437
3438
3439

3440
3441
3442
3443
3444
3445
3446
3447
3448

3449
3450

3451

3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465

3466
3467
3468

3469
3470
3471

3472
3473
3474
3475
3476

3477
3478

3479
3480
3481
3482
3483
3484
3485
3486

3487



3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
....
3530
3531
3532
3533
3534
3535
3536

3537
3538
3539
3540
3541

3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */
    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */
    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
................................................................................
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
    NULL                       /* truncate */
};
 
/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static const char *
BuildCmdLineBypassBS(
    const char *current,
    const char **bspos
) {


    /* mark first backslash possition */


    if (!*bspos) {
	*bspos = current;
    }
    do {
	current++;
    } while (*current == '\\');
    return current;
................................................................................
}

static void
QuoteCmdLineBackslash(
    Tcl_DString *dsPtr,
    const char *start,
    const char *current,
    const char *bspos
) {

    if (!bspos) {
	if (current > start) { /* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
    	if (bspos > start) { /* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}
................................................................................

static const char *
QuoteCmdLinePart(
    Tcl_DString *dsPtr,
    const char *start,
    const char *special,
    const char *specMetaChars,
    const char **bspos
) {

    if (!*bspos) {

	/* rest before special (before quote) */


	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
	start = special;
    } else {

	/* rest before first backslash and backslashes into new quoted block */


	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
	start = *bspos;
    }

    /*
     * escape all special chars enclosed in quotes like `"..."`, note that here we
     * don't must escape `\` (with `\`), because it's outside of the main quotes,
     * so `\` remains `\`, but important - not at end of part, because results as
     * before the quote,  so `%\%\` should be escaped as `"%\%"\\`).

     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
    	*bspos = NULL;
	special++;
	if (*special == '\\') {

	    /* bypass backslashes (and mark first backslash possition)*/


	    special = BuildCmdLineBypassBS(special, bspos);
	    if (*special == '\0') break;


	}
    } while (*special && strchr(specMetaChars, *special));
    if (!*bspos) {

	/* unescaped rest before quote */


	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
    } else {

	/* unescaped rest before first backslash (rather belongs to the main block) */



	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
    }
    TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
    return special;
}

static void
................................................................................
    const char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (WCHAR). */
{
    const char *arg, *start, *special, *bspos;
    int quote = 0, i;
    Tcl_DString ds;

    /* characters to enclose in quotes if unpaired quote flag set */
    static const char specMetaChars[] = "&|^<>!()%";
    /* character to enclose in quotes in any case (regardless unpaired-flag) */
    static const char specMetaChars2[] = "%";

    /* Quote flags:

     *   CL_ESCAPE   - escape argument;
     *   CL_QUOTE    - enclose in quotes;
     *   CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
     */
    enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};

    Tcl_DStringInit(&ds);
................................................................................

	quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
	bspos = NULL;
	if (arg[0] == '\0') {
	    quote = CL_QUOTE;
	} else {
	    for (start = arg;
		*start != '\0' &&
		    (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
		start++
	    ) {
		if (*start & 0x80) continue;


		if (TclIsSpaceProc(*start)) {
		    quote |= CL_QUOTE; /* quote only */
		    if (bspos) { /* if backslash found - escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
		if (strchr(specMetaChars, *start)) {
		    quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */
		    break;
		}
		if (*start == '"') {
		    quote |= CL_ESCAPE; /* escape only */
		    continue;
		}
		if (*start == '\\') {
		    bspos = start;
		    if (quote & CL_QUOTE) { /* if quote - escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
	    }
	    bspos = NULL;
	}
	if (quote & CL_QUOTE) {

	    /* start of argument (main opening quote-char) */


	    TclDStringAppendLiteral(&ds, "\"");
	}
	if (!(quote & CL_ESCAPE)) {

	    /* nothing to escape */


	    Tcl_DStringAppend(&ds, arg, -1);
	} else {
	    start = arg;
	    for (special = arg; *special != '\0'; ) {

		/* position of `\` is important before quote or at end (equal `\"` because quoted) */



		if (*special == '\\') {

		    /* bypass backslashes (and mark first backslash possition)*/


		    special = BuildCmdLineBypassBS(special, &bspos);
		    if (*special == '\0') break;


		}
		/* ["] */
		if (*special == '"') {

		    quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */





		    /* add part before (and escape backslashes before quote) */


		    QuoteCmdLineBackslash(&ds, start, special, bspos);
		    bspos = NULL;


		    /* escape using backslash */


		    TclDStringAppendLiteral(&ds, "\\\"");
		    start = ++special;
		    continue;
		}


		/* unpaired (escaped) quote causes special handling on meta-chars */



		if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos);



		    /* start to current or first backslash */


		    start = !bspos ? special : bspos;
		    continue;
		}


		/* special case for % - should be enclosed always (paired also) */



		if (strchr(specMetaChars2, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos);



		    /* start to current or first backslash */


		    start = !bspos ? special : bspos;
		    continue;
		}


		/* other not special (and not meta) character */


		bspos = NULL; /* reset last backslash possition (not interesting) */

		special++;
	    }


	    /* rest of argument (and escape backslashes before closing main quote) */



	    QuoteCmdLineBackslash(&ds, start, special,
	    	(quote & CL_QUOTE) ? bspos : NULL);
	}
	if (quote & CL_QUOTE) {

	    /* end of argument (main closing quote-char) */


	    TclDStringAppendLiteral(&ds, "\"");
	}
    }
    Tcl_DStringFree(linePtr);
    Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
    Tcl_DStringFree(&ds);
}
................................................................................
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /* avoid blocking if pipe-thread exited */

    timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI)
	|| TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
................................................................................
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };

	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
................................................................................
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
    PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
    HANDLE handle = NULL;
    DWORD count, err;
    int done = 0;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}

	if (!infoPtr) {
	    infoPtr = (PipeInfo *)pipeTI->clientData;
	    handle = ((WinFile *) infoPtr->readFile)->handle;
	}

	/*
	 * Try waiting for 0 bytes. This will block until some data is
	 * available on NT, but will return immediately on Win 95. So, if no
	 * data is available after the first read, we block until we can read
................................................................................
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
    pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
    pipeTI = ckalloc(sizeof(TclPipeThreadInfo));
#endif
    pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
    pipeTI->state = PTI_STATE_IDLE;
    pipeTI->clientData = clientData;
    pipeTI->evWakeUp = wakeEvent;
    return (*pipeTIPtr = pipeTI);
}
 
................................................................................
    HANDLE wakeEvent;

    if (!pipeTI) {
	return 0;
    }

    wakeEvent = pipeTI->evWakeUp;

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */


    /* reset work state of thread (idle/waiting) */


    if ((state = InterlockedCompareExchange(&pipeTI->state,

	    PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) {

	/* end of work, check the owner of structure */


	goto end;
    }


    /* entering wait */
    waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);



    if (waitResult != WAIT_OBJECT_0) {

	/*
	 * The control event was not signaled, so end of work (unexpected
	 * behaviour, main thread can be dead?).
	 */

	goto end;
    }


    /* try to set work state of thread */


    if ((state = InterlockedCompareExchange(&pipeTI->state,

	    PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) {

	/* end of work */


	goto end;
    }


    /* signaled to work */


    return 1;

end:

    /* end of work, check the owner of the TI structure */


    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
    	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
    	SetEvent(wakeEvent);
................................................................................
 *	1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
 *
 *----------------------------------------------------------------------
 */

int
TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent)

{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    HANDLE evControl;
    int state;

    if (!pipeTI) {
	return 1;
    }
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = wakeEvent;
    switch (
	(state = InterlockedCompareExchange(&pipeTI->state,
	    PTI_STATE_STOP, PTI_STATE_IDLE))
    ) {


	case PTI_STATE_IDLE:




	    /* Thread was idle/waiting, notify it goes teardown */
	    SetEvent(evControl);

	    *pipeTIPtr = NULL;

	case PTI_STATE_DOWN:

	return 1;

	default:
	    /*
	     * Thread works currently, we should try to end it, own the TI structure
	     * (because of possible sharing the joint structures with thread)

	     */

	    InterlockedExchange(&pipeTI->state, PTI_STATE_END);
	break;
    }

    return 0;
}
 
/*
................................................................................

    if (!pipeTI) {
	return;
    }
    pipeTI = *pipeTIPtr;
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = NULL;

    /*
     * Try to sane stop the pipe worker, corresponding its current state
     */
    switch (

	(state = InterlockedCompareExchange(&pipeTI->state,
	    PTI_STATE_STOP, PTI_STATE_IDLE))
    ) {

	case PTI_STATE_IDLE:




	    /* Thread was idle/waiting, notify it goes teardown */
	    SetEvent(evControl);


	    /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */



	    pipeTI = NULL;
	break;

	case PTI_STATE_STOP:

	    /* already stopped, thread frees himself (owns the TI structure) */


	    pipeTI = NULL;
	break;
	case PTI_STATE_DOWN:

	    /* Thread already down (?), do nothing */



	    /* we don't need to wait for it, but we should free pipeTI */

	    hThread = NULL;
	break;

	/* case PTI_STATE_WORK: */
	default:
	    /*
	     * Thread works currently, we should try to end it, own the TI structure
	     * (because of possible sharing the joint structures with thread)

	     */

	    if ((state = InterlockedCompareExchange(&pipeTI->state,
		    PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN
	    ) {


		/* we don't need to wait for it, but we should free pipeTI */

		hThread = NULL;
	    };

	break;
    }

    if (pipeTI && hThread) {
	DWORD exitCode;

	/*
................................................................................
	 * The thread may already have closed on its own. Check its exit
	 * code.
	 */

	GetExitCodeThread(hThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    int inExit = (TclInExit() || TclInThreadExit());

	    /*
	     * Set the stop event so that if the pipe thread is blocked
	     * somewhere, it may hereafter sane exit cleanly.
	     */

	    SetEvent(evControl);

	    /*
	     * Cancel all sync-IO of this thread (may be blocked there).
	     */

	    if (tclWinProcs.cancelSynchronousIo) {
		tclWinProcs.cancelSynchronousIo(hThread);
	    }

	    /*
	     * Wait at most 20 milliseconds for the reader thread to
	     * close (regarding TIP#398-fast-exit).
	     */


	    /* if we want TIP#398-fast-exit. */
	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {



		/*
		 * The thread must be blocked waiting for the pipe to
		 * become readable in ReadFile(). There isn't a clean way
		 * to exit the thread from this condition. We should
		 * terminate the child process instead to get the reader
		 * thread to fall out of ReadFile with a FALSE. (below) is
		 * not the correct way to do this, but will stay here
		 * until a better solution is found.
		 *
		 * Note that we need to guard against terminating the
		 * thread while it is in the middle of Tcl_ThreadAlert
		 * because it won't be able to release the notifier lock.
		 *
		 * Also note that terminating threads during their initialization or teardown phase

		 * may result in ntdll.dll's LoaderLock to remain locked indefinitely.
		 * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock.
		 * LdrpInitializeThread() is executed within new threads to perform

		 * initialization and to execute DllMain() of all loaded dlls.
		 * As a result, all new threads are deadlocked in their initialization phase and never execute,
		 * even though CreateThread() reports successful thread creation.

		 * This results in a very weird process-wide behavior, which is extremely hard to debug.
		 *
		 * THREADS SHOULD NEVER BE TERMINATED. Period.
		 *
		 * But for now, check if thread is exiting, and if so, let it die peacefully.

		 *
		 * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's).

		 */

		if ( pipeTI->state != PTI_STATE_DOWN
		  && WaitForSingleObject(hThread,
			inExit ? 50 : 5000) != WAIT_OBJECT_0
		) {
		    /* BUG: this leaks memory */
		    if (inExit || !TerminateThread(hThread, 0)) {

			/* in exit or terminate fails, just give thread a chance to exit */



			if (InterlockedExchange(&pipeTI->state,
				PTI_STATE_STOP) != PTI_STATE_DOWN) {
			    pipeTI = NULL;
			}
		    };
		}
	    }
	}
    }

    *pipeTIPtr = NULL;
    if (pipeTI) {
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
	CloseHandle(pipeTI->evControl);
#   ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#   else
	ckfree(pipeTI);
#   endif
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadExit --
................................................................................

void
TclPipeThreadExit(
    TclPipeThreadInfo **pipeTIPtr)
{
    LONG state;
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    /*
     * If state of thread was set to stop (exactly), we can sane free its info
     * structure, otherwise it is shared with main thread, so main thread will
     * own it.
     */

    if (!pipeTI) {
	return;
    }
    *pipeTIPtr = NULL;
    if ((state = InterlockedExchange(&pipeTI->state,
	    PTI_STATE_DOWN)) == PTI_STATE_STOP) {
	CloseHandle(pipeTI->evControl);
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
#   ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#   else
	ckfree(pipeTI);
	/* be sure all subsystems used are finalized */
	Tcl_FinalizeThread();
#   endif
    }
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */






|
<







 







|







 







|
<
>
>
|
>
>







 







|
<
>

|



|







 







|
<
>

>
|
>
>



>
|
>
>



>

|
|
|
|
>

>





>
|
>
>

|
>
>



>
|
>
>


>
|
>
>
>







 







|
|
|
|
|
|
|
>







 







|
|
|
<
|
>
>

|
|






|



|




|









>
|
>
>



>
|
>
>




>
|
>
>
>

>
|
>
>

|
>
>



>
|
>
>
>
>
>
|
>
>


>
>
|
>
>




>
>
|
>
>
>

|
>
>
>
|
>
>



>
>
|
>
>
>

|
>
>
>
|
>
>



>
>
|
>
>
|
>


>
>
|
>
>
>

|


>
|
>
>







 







>
|
|







 







>







 







|










>






|







 







|







 







>




>
|
>
>
|
>
|
>
|
>
>


>
>
|
<
>

>

<




>



>
|
>
>
|
>
|
>
|
>
>



>
|
>
>


|
>
|
>
>







 







|
>










<
|
|
<
<
>
|
>
>
>

<
|
<
|
<
|
<


|
|
|
|
>
|
>
|







 







>



<
>
|
|
|
<
|
>
>
>

<
|

>
|
>
>
>
|


|
>
|
>
>
|

|
>
|
>

>
|
>
|



|
|
|
|
>
|
>
|
|
<
>
>
|
>
|
<
>







 







<

>










>





|
|


>
|
<
>

>

|
|
|
|
|
<
|

|
|
|

|
>
|
|
|
>
|
|
|
>
|



|
>

|
>


|
|
|
<


>
|
>
>
>




|











|

|

|







 







>





>




|
|




|

|



|










120
121
122
123
124
125
126
127

128
129
130
131
132
133
134
...
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
....
1423
1424
1425
1426
1427
1428
1429
1430

1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
....
1443
1444
1445
1446
1447
1448
1449
1450

1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
....
1465
1466
1467
1468
1469
1470
1471
1472

1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
....
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
....
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584

1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
....
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
....
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
....
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
....
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
....
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344

3345
3346
3347
3348

3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
....
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422

3423
3424


3425
3426
3427
3428
3429
3430

3431

3432

3433

3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
....
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489

3490
3491
3492
3493

3494
3495
3496
3497
3498

3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536

3537
3538
3539
3540
3541

3542
3543
3544
3545
3546
3547
3548
3549
....
3550
3551
3552
3553
3554
3555
3556

3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580

3581
3582
3583
3584
3585
3586
3587
3588
3589

3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619

3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
....
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object. */

    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */
    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */
    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
................................................................................
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
    NULL			/* truncate */
};
 
/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static const char *
BuildCmdLineBypassBS(
    const char *current,
    const char **bspos)

{
    /*
     * Mark first backslash position.
     */

    if (!*bspos) {
	*bspos = current;
    }
    do {
	current++;
    } while (*current == '\\');
    return current;
................................................................................
}

static void
QuoteCmdLineBackslash(
    Tcl_DString *dsPtr,
    const char *start,
    const char *current,
    const char *bspos)

{
    if (!bspos) {
	if (current > start) {	/* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
    	if (bspos > start) {	/* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}
................................................................................

static const char *
QuoteCmdLinePart(
    Tcl_DString *dsPtr,
    const char *start,
    const char *special,
    const char *specMetaChars,
    const char **bspos)

{
    if (!*bspos) {
	/*
	 * Rest before special (before quote).
	 */

	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
	start = special;
    } else {
	/*
	 * Rest before first backslash and backslashes into new quoted block.
	 */

	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
	start = *bspos;
    }

    /*
     * escape all special chars enclosed in quotes like `"..."`, note that
     * here we don't must escape `\` (with `\`), because it's outside of the
     * main quotes, so `\` remains `\`, but important - not at end of part,
     * because results as before the quote, so `%\%\` should be escaped as
     * `"%\%"\\`).
     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
    	*bspos = NULL;
	special++;
	if (*special == '\\') {
	    /*
	     * Bypass backslashes (and mark first backslash position).
	     */

	    special = BuildCmdLineBypassBS(special, bspos);
	    if (*special == '\0') {
		break;
	    }
	}
    } while (*special && strchr(specMetaChars, *special));
    if (!*bspos) {
	/*
	 * Unescaped rest before quote.
	 */

	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
    } else {
	/*
	 * Unescaped rest before first backslash (rather belongs to the main
	 * block).
	 */

	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
    }
    TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
    return special;
}

static void
................................................................................
    const char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (WCHAR). */
{
    const char *arg, *start, *special, *bspos;
    int quote = 0, i;
    Tcl_DString ds;
    static const char specMetaChars[] = "&|^<>!()%";
				/* Characters to enclose in quotes if unpaired
				 * quote flag set. */
    static const char specMetaChars2[] = "%";
				/* Character to enclose in quotes in any case
				 * (regardless of unpaired-flag). */
    /*
     * Quote flags:
     *   CL_ESCAPE   - escape argument;
     *   CL_QUOTE    - enclose in quotes;
     *   CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
     */
    enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};

    Tcl_DStringInit(&ds);
................................................................................

	quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
	bspos = NULL;
	if (arg[0] == '\0') {
	    quote = CL_QUOTE;
	} else {
	    for (start = arg;
		    *start != '\0' &&
			(quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
		    start++) {

		if (*start & 0x80) {
		    continue;
		}
		if (TclIsSpaceProc(*start)) {
		    quote |= CL_QUOTE;	/* quote only */
		    if (bspos) {	/* if backslash found, escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
		if (strchr(specMetaChars, *start)) {
		    quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
		    break;
		}
		if (*start == '"') {
		    quote |= CL_ESCAPE;		/* escape only */
		    continue;
		}
		if (*start == '\\') {
		    bspos = start;
		    if (quote & CL_QUOTE) {	/* if quote, escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
	    }
	    bspos = NULL;
	}
	if (quote & CL_QUOTE) {
	    /*
	     * Start of argument (main opening quote-char).
	     */

	    TclDStringAppendLiteral(&ds, "\"");
	}
	if (!(quote & CL_ESCAPE)) {
	    /*
	     * Nothing to escape.
	     */

	    Tcl_DStringAppend(&ds, arg, -1);
	} else {
	    start = arg;
	    for (special = arg; *special != '\0'; ) {
		/*
		 * Position of `\` is important before quote or at end (equal
		 * `\"` because quoted).
		 */

		if (*special == '\\') {
		    /*
		     * Bypass backslashes (and mark first backslash position)
		     */

		    special = BuildCmdLineBypassBS(special, &bspos);
		    if (*special == '\0') {
			break;
		    }
		}
		/* ["] */
		if (*special == '"') {
		    /*
		     * Invert the unpaired flag - observe unpaired quotes
		     */

		    quote ^= CL_UNPAIRED;

		    /*
		     * Add part before (and escape backslashes before quote).
		     */

		    QuoteCmdLineBackslash(&ds, start, special, bspos);
		    bspos = NULL;

		    /*
		     * Escape using backslash
		     */

		    TclDStringAppendLiteral(&ds, "\\\"");
		    start = ++special;
		    continue;
		}

		/*
		 * Unpaired (escaped) quote causes special handling on
		 * meta-chars
		 */

		if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special,
			    specMetaChars, &bspos);

		    /*
		     * Start to current or first backslash
		     */

		    start = !bspos ? special : bspos;
		    continue;
		}

		/*
		 * Special case for % - should be enclosed always (paired
		 * also)
		 */

		if (strchr(specMetaChars2, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special,
			    specMetaChars2, &bspos);

		    /*
		     * Start to current or first backslash.
		     */

		    start = !bspos ? special : bspos;
		    continue;
		}

		/*
		 * Other not special (and not meta) character
		 */

		bspos = NULL;		/* reset last backslash position (not
					 * interesting) */
		special++;
	    }

	    /*
	     * Rest of argument (and escape backslashes before closing main
	     * quote)
	     */

	    QuoteCmdLineBackslash(&ds, start, special,
		    (quote & CL_QUOTE) ? bspos : NULL);
	}
	if (quote & CL_QUOTE) {
	    /*
	     * End of argument (main closing quote-char)
	     */

	    TclDStringAppendLiteral(&ds, "\"");
	}
    }
    Tcl_DStringFree(linePtr);
    Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
    Tcl_DStringFree(&ds);
}
................................................................................
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /* avoid blocking if pipe-thread exited */
    timeout = ((infoPtr->flags & PIPE_ASYNC)
	    || !TclPipeThreadIsAlive(&infoPtr->writeTI)
	    || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
................................................................................
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };

	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
................................................................................
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
    PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
    HANDLE handle = NULL;
    DWORD count, err;
    int done = 0;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}

	if (!infoPtr) {
	    infoPtr = (PipeInfo *) pipeTI->clientData;
	    handle = ((WinFile *) infoPtr->readFile)->handle;
	}

	/*
	 * Try waiting for 0 bytes. This will block until some data is
	 * available on NT, but will return immediately on Win 95. So, if no
	 * data is available after the first read, we block until we can read
................................................................................
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
    pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
    pipeTI = ckalloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
    pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
    pipeTI->state = PTI_STATE_IDLE;
    pipeTI->clientData = clientData;
    pipeTI->evWakeUp = wakeEvent;
    return (*pipeTIPtr = pipeTI);
}
 
................................................................................
    HANDLE wakeEvent;

    if (!pipeTI) {
	return 0;
    }

    wakeEvent = pipeTI->evWakeUp;

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */

    /*
     * Reset work state of thread (idle/waiting)
     */

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
	    PTI_STATE_WORK);
    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
	/*
	 * End of work, check the owner of structure.
	 */

	goto end;
    }

    /*
     * Entering wait

     */

    waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
    if (waitResult != WAIT_OBJECT_0) {

	/*
	 * The control event was not signaled, so end of work (unexpected
	 * behaviour, main thread can be dead?).
	 */

	goto end;
    }

    /*
     * Try to set work state of thread
     */

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
	    PTI_STATE_IDLE);
    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
	/*
	 * End of work
	 */

	goto end;
    }

    /*
     * Signaled to work.
     */

    return 1;

  end:
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
    	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
    	SetEvent(wakeEvent);
................................................................................
 *	1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
 *
 *----------------------------------------------------------------------
 */

int
TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr,
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    HANDLE evControl;
    int state;

    if (!pipeTI) {
	return 1;
    }
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = wakeEvent;

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);


    switch (state) {
    case PTI_STATE_IDLE:
	/*
	 * Thread was idle/waiting, notify it goes teardown
	 */


	SetEvent(evControl);

	*pipeTIPtr = NULL;

    case PTI_STATE_DOWN:

	return 1;

    default:
	/*
	 * Thread works currently, we should try to end it, own the TI
	 * structure (because of possible sharing the joint structures with
	 * thread)
	 */

	InterlockedExchange(&pipeTI->state, PTI_STATE_END);
	break;
    }

    return 0;
}
 
/*
................................................................................

    if (!pipeTI) {
	return;
    }
    pipeTI = *pipeTIPtr;
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = NULL;

    /*
     * Try to sane stop the pipe worker, corresponding its current state
     */


    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);
    switch (state) {

    case PTI_STATE_IDLE:
	/*
	 * Thread was idle/waiting, notify it goes teardown
	 */


	SetEvent(evControl);

	/*
	 * We don't need to wait for it at all, thread frees himself (owns the
	 * TI structure)
	 */

	pipeTI = NULL;
	break;

    case PTI_STATE_STOP:
	/*
	 * Already stopped, thread frees himself (owns the TI structure)
	 */

	pipeTI = NULL;
	break;
    case PTI_STATE_DOWN:
	/*
	 * Thread already down (?), do nothing
	 */

	/*
	 * We don't need to wait for it, but we should free pipeTI
	 */
	hThread = NULL;
	break;

	/* case PTI_STATE_WORK: */
    default:
	/*
	 * Thread works currently, we should try to end it, own the TI
	 * structure (because of possible sharing the joint structures with
	 * thread)
	 */

	state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
		PTI_STATE_WORK);

	if (state == PTI_STATE_DOWN) {
	    /*
	     * We don't need to wait for it, but we should free pipeTI
	     */
	    hThread = NULL;

	}
	break;
    }

    if (pipeTI && hThread) {
	DWORD exitCode;

	/*
................................................................................
	 * The thread may already have closed on its own. Check its exit
	 * code.
	 */

	GetExitCodeThread(hThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    int inExit = (TclInExit() || TclInThreadExit());

	    /*
	     * Set the stop event so that if the pipe thread is blocked
	     * somewhere, it may hereafter sane exit cleanly.
	     */

	    SetEvent(evControl);

	    /*
	     * Cancel all sync-IO of this thread (may be blocked there).
	     */

	    if (tclWinProcs.cancelSynchronousIo) {
		tclWinProcs.cancelSynchronousIo(hThread);
	    }

	    /*
	     * Wait at most 20 milliseconds for the reader thread to close
	     * (regarding TIP#398-fast-exit).
	     */

	    /*
	     * If we want TIP#398-fast-exit.

	     */

	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
		/*
		 * The thread must be blocked waiting for the pipe to become
		 * readable in ReadFile(). There isn't a clean way to exit the
		 * thread from this condition. We should terminate the child
		 * process instead to get the reader thread to fall out of
		 * ReadFile with a FALSE. (below) is not the correct way to do

		 * this, but will stay here until a better solution is found.
		 *
		 * Note that we need to guard against terminating the thread
		 * while it is in the middle of Tcl_ThreadAlert because it
		 * won't be able to release the notifier lock.
		 *
		 * Also note that terminating threads during their
		 * initialization or teardown phase may result in ntdll.dll's
		 * LoaderLock to remain locked indefinitely.  This causes
		 * ntdll.dll's LdrpInitializeThread() to deadlock trying to
		 * acquire LoaderLock.  LdrpInitializeThread() is executed
		 * within new threads to perform initialization and to execute
		 * DllMain() of all loaded dlls.  As a result, all new threads
		 * are deadlocked in their initialization phase and never
		 * execute, even though CreateThread() reports successful
		 * thread creation.  This results in a very weird process-wide
		 * behavior, which is extremely hard to debug.
		 *
		 * THREADS SHOULD NEVER BE TERMINATED. Period.
		 *
		 * But for now, check if thread is exiting, and if so, let it
		 * die peacefully.
		 *
		 * Also don't terminate if in exit (otherwise deadlocked in
		 * ntdll.dll's).
		 */

		if (pipeTI->state != PTI_STATE_DOWN
			&& WaitForSingleObject(hThread,
				inExit ? 50 : 5000) != WAIT_OBJECT_0) {

		    /* BUG: this leaks memory */
		    if (inExit || !TerminateThread(hThread, 0)) {
			/*
			 * in exit or terminate fails, just give thread a
			 * chance to exit
			 */

			if (InterlockedExchange(&pipeTI->state,
				PTI_STATE_STOP) != PTI_STATE_DOWN) {
			    pipeTI = NULL;
			}
		    }
		}
	    }
	}
    }

    *pipeTIPtr = NULL;
    if (pipeTI) {
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
	CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	ckfree(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadExit --
................................................................................

void
TclPipeThreadExit(
    TclPipeThreadInfo **pipeTIPtr)
{
    LONG state;
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    /*
     * If state of thread was set to stop (exactly), we can sane free its info
     * structure, otherwise it is shared with main thread, so main thread will
     * own it.
     */

    if (!pipeTI) {
	return;
    }
    *pipeTIPtr = NULL;
    state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
    if (state == PTI_STATE_STOP) {
	CloseHandle(pipeTI->evControl);
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	ckfree(pipeTI);
	/* be sure all subsystems used are finalized */
	Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */
    }
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */