Check-in [8a9080996d]
Not logged in

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

Overview
Comment:More booleans.
Timelines: family | ancestors | descendants | both | c-std-update
Files: files | file ages | folders
SHA3-256: 8a9080996d46742fd21fa467d6f4734383960c5e0d1e7930a9650eaa51a3c163
User & Date: dkf 2025-08-12 09:06:36.030
Context
2025-08-12
10:16
merge trunk check-in: 1ea33fb12b user: dkf tags: c-std-update
09:06
More booleans. check-in: 8a9080996d user: dkf tags: c-std-update
2025-08-06
09:34
merge trunk check-in: d41ff65d5d user: dkf tags: c-std-update
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tclAssembly.c.
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		ValidateJumpTargets(AssemblyEnv*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
static int		BytecodeMightThrow(unsigned char);
static int		CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
static int		CheckNamespaceQualifiers(Tcl_Interp*, const char*,
			    Tcl_Size);
static int		CheckNonNegative(Tcl_Interp*, Tcl_Size);
static int		CheckOneByte(Tcl_Interp*, Tcl_Size);
static int		CheckSignedOneByte(Tcl_Interp*, Tcl_Size);
static int		CheckStack(AssemblyEnv*);







|







247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
static void		BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
			    int count);
static int		BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int		ValidateJumpTargets(AssemblyEnv*);
static int		CheckForUnclosedCatches(AssemblyEnv*);
static int		CheckForThrowInWrongContext(AssemblyEnv*);
static int		CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
static bool		BytecodeMightThrow(unsigned char);
static int		CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
static int		CheckNamespaceQualifiers(Tcl_Interp*, const char*,
			    Tcl_Size);
static int		CheckNonNegative(Tcl_Interp*, Tcl_Size);
static int		CheckOneByte(Tcl_Interp*, Tcl_Size);
static int		CheckSignedOneByte(Tcl_Interp*, Tcl_Size);
static int		CheckStack(AssemblyEnv*);
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
 *-----------------------------------------------------------------------------
 *
 * BytecodeMightThrow --
 *
 *	Tests if a given bytecode instruction might throw an exception.
 *
 * Results:
 *	Returns 1 if the bytecode might throw an exception, 0 if the
 *	instruction is known never to throw.
 *
 *-----------------------------------------------------------------------------
 */

static int
BytecodeMightThrow(
    unsigned char opcode)
{
    /*
     * Binary search on the non-throwing bytecode list.
     */








|





|







3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
 *-----------------------------------------------------------------------------
 *
 * BytecodeMightThrow --
 *
 *	Tests if a given bytecode instruction might throw an exception.
 *
 * Results:
 *	Returns trye if the bytecode might throw an exception, false if the
 *	instruction is known never to throw.
 *
 *-----------------------------------------------------------------------------
 */

static bool
BytecodeMightThrow(
    unsigned char opcode)
{
    /*
     * Binary search on the non-throwing bytecode list.
     */

3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
	} else if (opcode > c) {
	    min = mid+1;
	} else {
	    /*
	     * Opcode is nonthrowing.
	     */

	    return 0;
	}
    }

    return 1;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckStack --
 *







|



|







3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
	} else if (opcode > c) {
	    min = mid+1;
	} else {
	    /*
	     * Opcode is nonthrowing.
	     */

	    return false;
	}
    }

    return true;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckStack --
 *
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
				/* Enclosing catch if execution falls thru */
    enum BasicBlockCatchState fallThruState;
				/* Catch state of the successor block */
    BasicBlock* jumpEnclosing;	/* Enclosing catch if execution goes to jump
				 * target */
    enum BasicBlockCatchState jumpState;
				/* Catch state of the jump target */
    int changed = 0;		/* Flag == 1 iff successor blocks need to be
				 * checked because the state of this block has
				 * changed. */
    BasicBlock* jumpTarget;	/* Basic block where a jump goes */
    Tcl_HashSearch jtSearch;	/* Hash search control for a jumptable */
    Tcl_HashEntry* jtEntry;	/* Entry in a jumptable */
    Tcl_Obj* targetLabel;	/* Target label from a jumptable */
    Tcl_HashEntry* entry;	/* Entry from the label table */







|







3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
				/* Enclosing catch if execution falls thru */
    enum BasicBlockCatchState fallThruState;
				/* Catch state of the successor block */
    BasicBlock* jumpEnclosing;	/* Enclosing catch if execution goes to jump
				 * target */
    enum BasicBlockCatchState jumpState;
				/* Catch state of the jump target */
    bool changed = false;	/* True iff successor blocks need to be
				 * checked because the state of this block has
				 * changed. */
    BasicBlock* jumpTarget;	/* Basic block where a jump goes */
    Tcl_HashSearch jtSearch;	/* Hash search control for a jumptable */
    Tcl_HashEntry* jtEntry;	/* Entry in a jumptable */
    Tcl_Obj* targetLabel;	/* Target label from a jumptable */
    Tcl_HashEntry* entry;	/* Entry from the label table */
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
	    Tcl_SetErrorLine(interp, bbPtr->startLine);
	    TclSetErrorCode(interp, "TCL", "ASSEM", "BADCATCH");
	}
	return TCL_ERROR;
    }
    if (state > bbPtr->catchState) {
	bbPtr->catchState = state;
	changed = 1;
    }

    /*
     * If this block has been visited before, and its state hasn't changed,
     * we're done with it for now.
     */








|







3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
	    Tcl_SetErrorLine(interp, bbPtr->startLine);
	    TclSetErrorCode(interp, "TCL", "ASSEM", "BADCATCH");
	}
	return TCL_ERROR;
    }
    if (state > bbPtr->catchState) {
	bbPtr->catchState = state;
	changed = true;
    }

    /*
     * If this block has been visited before, and its state hasn't changed,
     * we're done with it for now.
     */

Changes to generic/tclAsync.c.
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
				 * associated to. */
    Tcl_ThreadId originThrdId;	/* Origin thread where this token was created
				 * and where it will be yielded. */
    void *notifierData;		/* Platform notifier data or NULL. */
} AsyncHandler;

struct ThreadSpecificData_Async {
    int asyncReady;		/* This is set to 1 whenever a handler becomes
				 * ready and it is cleared to zero whenever
				 * Tcl_AsyncInvoke is called. It can be
				 * checked elsewhere in the application by
				 * calling Tcl_AsyncReady to see if
				 * Tcl_AsyncInvoke should be invoked. */
    int asyncActive;		/* Indicates whether Tcl_AsyncInvoke is
				 * currently working. If so then we won't set
				 * asyncReady again until Tcl_AsyncInvoke
				 * returns. */
};
static Tcl_ThreadDataKey dataKey;

/* Mutex to protect linked-list of AsyncHandlers in the process. */







|
|
|
|


|







37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
				 * associated to. */
    Tcl_ThreadId originThrdId;	/* Origin thread where this token was created
				 * and where it will be yielded. */
    void *notifierData;		/* Platform notifier data or NULL. */
} AsyncHandler;

struct ThreadSpecificData_Async {
    bool asyncReady;		/* This is set to true whenever a handler
				 * becomes ready and it is cleared to zero
				 * whenever Tcl_AsyncInvoke is called. It can
				 * be checked elsewhere in the application by
				 * calling Tcl_AsyncReady to see if
				 * Tcl_AsyncInvoke should be invoked. */
    bool asyncActive;		/* Indicates whether Tcl_AsyncInvoke is
				 * currently working. If so then we won't set
				 * asyncReady again until Tcl_AsyncInvoke
				 * returns. */
};
static Tcl_ThreadDataKey dataKey;

/* Mutex to protect linked-list of AsyncHandlers in the process. */
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
    Tcl_AsyncHandler async)	/* Token for handler. */
{
    AsyncHandler *token = (AsyncHandler *) async;

    Tcl_MutexLock(&asyncMutex);
    token->ready = 1;
    if (!token->originTsd->asyncActive) {
	token->originTsd->asyncReady = 1;
	Tcl_ThreadAlert(token->originThrdId);
    }
    Tcl_MutexUnlock(&asyncMutex);
}

/*
 *----------------------------------------------------------------------







|







192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
    Tcl_AsyncHandler async)	/* Token for handler. */
{
    AsyncHandler *token = (AsyncHandler *) async;

    Tcl_MutexLock(&asyncMutex);
    token->ready = 1;
    if (!token->originTsd->asyncActive) {
	token->originTsd->asyncReady = true;
	Tcl_ThreadAlert(token->originThrdId);
    }
    Tcl_MutexUnlock(&asyncMutex);
}

/*
 *----------------------------------------------------------------------
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

    return TclAsyncNotifier(sigNumber, token->originThrdId,
	    token->notifierData, &token->ready, -1);
#else
    (void)sigNumber;

    Tcl_AsyncMark(async);
    return 1;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclAsyncMarkFromNotifier --







|







230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

    return TclAsyncNotifier(sigNumber, token->originThrdId,
	    token->notifierData, &token->ready, -1);
#else
    (void)sigNumber;

    Tcl_AsyncMark(async);
    return true;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclAsyncMarkFromNotifier --
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
{
    Tcl_MutexLock(&asyncMutex);
    for (AsyncHandler *token = firstHandler; token != NULL;
	    token = token->nextPtr) {
	if (token->ready == -1) {
	    token->ready = 1;
	    if (!token->originTsd->asyncActive) {
		token->originTsd->asyncReady = 1;
		Tcl_ThreadAlert(token->originThrdId);
	    }
	}
    }
    Tcl_MutexUnlock(&asyncMutex);
}








|







260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
{
    Tcl_MutexLock(&asyncMutex);
    for (AsyncHandler *token = firstHandler; token != NULL;
	    token = token->nextPtr) {
	if (token->ready == -1) {
	    token->ready = 1;
	    if (!token->originTsd->asyncActive) {
		token->originTsd->asyncReady = true;
		Tcl_ThreadAlert(token->originThrdId);
	    }
	}
    }
    Tcl_MutexUnlock(&asyncMutex);
}

301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_ThreadId self = Tcl_GetCurrentThread();

    Tcl_MutexLock(&asyncMutex);

    if (tsdPtr->asyncReady == 0) {
	Tcl_MutexUnlock(&asyncMutex);
	return code;
    }
    tsdPtr->asyncReady = 0;
    tsdPtr->asyncActive = 1;
    if (interp == NULL) {
	code = 0;
    }

    /*
     * Make one or more passes over the list of handlers, invoking at most one
     * handler in each pass. After invoking a handler, go back to the start of







|



|
|







301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
{
    AsyncHandler *asyncPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_ThreadId self = Tcl_GetCurrentThread();

    Tcl_MutexLock(&asyncMutex);

    if (!tsdPtr->asyncReady) {
	Tcl_MutexUnlock(&asyncMutex);
	return code;
    }
    tsdPtr->asyncReady = false;
    tsdPtr->asyncActive = true;
    if (interp == NULL) {
	code = 0;
    }

    /*
     * Make one or more passes over the list of handlers, invoking at most one
     * handler in each pass. After invoking a handler, go back to the start of
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
	    break;
	}
	asyncPtr->ready = 0;
	Tcl_MutexUnlock(&asyncMutex);
	code = asyncPtr->proc(asyncPtr->clientData, interp, code);
	Tcl_MutexLock(&asyncMutex);
    }
    tsdPtr->asyncActive = 0;
    Tcl_MutexUnlock(&asyncMutex);
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|







339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
	    break;
	}
	asyncPtr->ready = 0;
	Tcl_MutexUnlock(&asyncMutex);
	code = asyncPtr->proc(asyncPtr->clientData, interp, code);
	Tcl_MutexLock(&asyncMutex);
    }
    tsdPtr->asyncActive = false;
    Tcl_MutexUnlock(&asyncMutex);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
int
Tcl_AsyncReady(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return tsdPtr->asyncReady;
}

int *
TclGetAsyncReadyPtr(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return &(tsdPtr->asyncReady);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|













427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
int
Tcl_AsyncReady(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return tsdPtr->asyncReady;
}

bool *
TclGetAsyncReadyPtr(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    return &(tsdPtr->asyncReady);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclBasic.c.
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
    char *result;		/* The script cancellation result or NULL for
				 * a default result. */
    Tcl_Size length;		/* Length of the above error message. */
    void *clientData;		/* Not used. */
    int flags;			/* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);

/*
 * Table used to map command implementation functions to a human-readable type
 * name, for [info type]. The keys in the table are function addresses, and
 * the values in the table are static char* containing strings in Tcl's
 * internal encoding (almost UTF-8).
 */

static Tcl_HashTable commandTypeTable;
static int commandTypeInit = 0;
TCL_DECLARE_MUTEX(commandTypeLock);

/*
 * Declarations for managing contexts for non-recursive coroutines. Contexts
 * are used to save the evaluation state between NR calls to each coro.
 */








|










|







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
    char *result;		/* The script cancellation result or NULL for
				 * a default result. */
    Tcl_Size length;		/* Length of the above error message. */
    void *clientData;		/* Not used. */
    int flags;			/* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static bool cancelTableInitialized = false;	/* false means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);

/*
 * Table used to map command implementation functions to a human-readable type
 * name, for [info type]. The keys in the table are function addresses, and
 * the values in the table are static char* containing strings in Tcl's
 * internal encoding (almost UTF-8).
 */

static Tcl_HashTable commandTypeTable;
static bool commandTypeInit = false;
TCL_DECLARE_MUTEX(commandTypeLock);

/*
 * Declarations for managing contexts for non-recursive coroutines. Contexts
 * are used to save the evaluation state between NR calls to each coro.
 */

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
 *----------------------------------------------------------------------
 */

void
TclFinalizeEvaluation(void)
{
    Tcl_MutexLock(&cancelLock);
    if (cancelTableInitialized == 1) {
	Tcl_DeleteHashTable(&cancelTable);
	cancelTableInitialized = 0;
    }
    Tcl_MutexUnlock(&cancelLock);

    Tcl_MutexLock(&commandTypeLock);
    if (commandTypeInit) {
	Tcl_DeleteHashTable(&commandTypeTable);
	commandTypeInit = 0;
    }
    Tcl_MutexUnlock(&commandTypeLock);
}

/*
 *----------------------------------------------------------------------
 *







|

|






|







626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
 *----------------------------------------------------------------------
 */

void
TclFinalizeEvaluation(void)
{
    Tcl_MutexLock(&cancelLock);
    if (cancelTableInitialized) {
	Tcl_DeleteHashTable(&cancelTable);
	cancelTableInitialized = false;
    }
    Tcl_MutexUnlock(&cancelLock);

    Tcl_MutexLock(&commandTypeLock);
    if (commandTypeInit) {
	Tcl_DeleteHashTable(&commandTypeTable);
	commandTypeInit = false;
    }
    Tcl_MutexUnlock(&commandTypeLock);
}

/*
 *----------------------------------------------------------------------
 *
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
    }
    if ((offsetof(Tcl_StatBuf,st_atime) != 32)
	    || (offsetof(Tcl_StatBuf,st_ctime) != 48)) {
	Tcl_Panic("<sys/stat.h> is not compatible with VS2005+");
    }
#endif

    if (cancelTableInitialized == 0) {
	Tcl_MutexLock(&cancelLock);
	if (cancelTableInitialized == 0) {
	    Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
	    cancelTableInitialized = 1;
	}

	Tcl_MutexUnlock(&cancelLock);
    }

#undef TclObjInterpProc
    if (commandTypeInit == 0) {
	TclRegisterCommandTypeName(TclObjInterpProc, "proc");
	TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
	TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
	TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
	TclRegisterCommandTypeName(TclChildObjCmd, "interp");
	TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
	TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");







|

|

|






|







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
    }
    if ((offsetof(Tcl_StatBuf,st_atime) != 32)
	    || (offsetof(Tcl_StatBuf,st_ctime) != 48)) {
	Tcl_Panic("<sys/stat.h> is not compatible with VS2005+");
    }
#endif

    if (!cancelTableInitialized) {
	Tcl_MutexLock(&cancelLock);
	if (!cancelTableInitialized) {
	    Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS);
	    cancelTableInitialized = true;
	}

	Tcl_MutexUnlock(&cancelLock);
    }

#undef TclObjInterpProc
    if (!commandTypeInit) {
	TclRegisterCommandTypeName(TclObjInterpProc, "proc");
	TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
	TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
	TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias");
	TclRegisterCommandTypeName(TclChildObjCmd, "interp");
	TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
	TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
    Tcl_IncrRefCount(iPtr->eiVar);
    iPtr->errorStack = Tcl_NewListObj(0, NULL);
    Tcl_IncrRefCount(iPtr->errorStack);
    iPtr->resetErrorStack = 1;
    TclNewLiteralStringObj(iPtr->upLiteral,"UP");
    Tcl_IncrRefCount(iPtr->upLiteral);
    TclNewLiteralStringObj(iPtr->callLiteral,"CALL");
    Tcl_IncrRefCount(iPtr->callLiteral);
    TclNewLiteralStringObj(iPtr->innerLiteral,"INNER");
    Tcl_IncrRefCount(iPtr->innerLiteral);
    iPtr->innerContext = Tcl_NewListObj(0, NULL);







|







903
904
905
906
907
908
909
910
911
912
913
914
915
916
917

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
    Tcl_IncrRefCount(iPtr->eiVar);
    iPtr->errorStack = Tcl_NewListObj(0, NULL);
    Tcl_IncrRefCount(iPtr->errorStack);
    iPtr->resetErrorStack = true;
    TclNewLiteralStringObj(iPtr->upLiteral,"UP");
    Tcl_IncrRefCount(iPtr->upLiteral);
    TclNewLiteralStringObj(iPtr->callLiteral,"CALL");
    Tcl_IncrRefCount(iPtr->callLiteral);
    TclNewLiteralStringObj(iPtr->innerLiteral,"INNER");
    Tcl_IncrRefCount(iPtr->innerLiteral);
    iPtr->innerContext = Tcl_NewListObj(0, NULL);
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373

void
TclRegisterCommandTypeName(
    Tcl_ObjCmdProc *implementationProc,
    const char *nameStr)
{
    Tcl_MutexLock(&commandTypeLock);
    if (commandTypeInit == 0) {
	Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
	commandTypeInit = 1;
    }

    Tcl_HashEntry *hPtr;
    if (nameStr != NULL) {
	int isNew;

	hPtr = Tcl_CreateHashEntry(&commandTypeTable,







|

|







1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373

void
TclRegisterCommandTypeName(
    Tcl_ObjCmdProc *implementationProc,
    const char *nameStr)
{
    Tcl_MutexLock(&commandTypeLock);
    if (!commandTypeInit) {
	Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
	commandTypeInit = true;
    }

    Tcl_HashEntry *hPtr;
    if (nameStr != NULL) {
	int isNew;

	hPtr = Tcl_CreateHashEntry(&commandTypeTable,
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
    int code = TCL_ERROR;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    Tcl_MutexLock(&cancelLock);
    if (cancelTableInitialized != 1) {
	/*
	 * No CancelInfo hash table (Tcl_CreateInterp has never been called?)
	 */

	goto done;
    }
    Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cancelTable, interp);







|







4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
    int code = TCL_ERROR;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    Tcl_MutexLock(&cancelLock);
    if (!cancelTableInitialized) {
	/*
	 * No CancelInfo hash table (Tcl_CreateInterp has never been called?)
	 */

	goto done;
    }
    Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cancelTable, interp);
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
    Tcl_Interp *interp = corPtr->eePtr->interp;
    Tcl_InterpState state = Tcl_SaveInterpState(interp, result);

    NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
    NRE_ASSERT(corPtr->eePtr != NULL);
    NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);

    corPtr->eePtr->rewind = 1;
    TclNRAddCallback(interp, RewindCoroutineCallback, state);
    return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}

static void
DeleteCoroutine(
    void *clientData)







|







8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
    Tcl_Interp *interp = corPtr->eePtr->interp;
    Tcl_InterpState state = Tcl_SaveInterpState(interp, result);

    NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
    NRE_ASSERT(corPtr->eePtr != NULL);
    NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);

    corPtr->eePtr->rewind = true;
    TclNRAddCallback(interp, RewindCoroutineCallback, state);
    return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}

static void
DeleteCoroutine(
    void *clientData)
Changes to generic/tclBinary.c.
47
48
49
50
51
52
53







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
 * drops, and there is very little gain from larger maximum cache sizes (the
 * value below is chosen to allow caching to work in full with conversion of
 * bytes.) - DKF
 */

#define BINARY_SCAN_MAX_CACHE	260








/*
 * Prototypes for local procedures defined in this file:
 */

static void		DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr);
static void		FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int		GetFormatSpec(const char **formatPtr, char *cmdPtr,
			    Tcl_Size *countPtr, int *flagsPtr);
static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
			    int flags, Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Size limit,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    size_t length, int type);
/* Binary ensemble commands */
static Tcl_ObjCmdProc	BinaryFormatCmd;
static Tcl_ObjCmdProc	BinaryScanCmd;
/* Binary encoding sub-ensemble commands */
static Tcl_ObjCmdProc	BinaryEncodeHex;







>
>
>
>
>
>
>









|







|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 * drops, and there is very little gain from larger maximum cache sizes (the
 * value below is chosen to allow caching to work in full with conversion of
 * bytes.) - DKF
 */

#define BINARY_SCAN_MAX_CACHE	260

typedef enum ReversingModes {
    REVERSE_NO = 0,	// No re-ordering needed.
    REVERSE_YES = 1,	// Reverse the bytes:	01234567 <-> 76543210 (little to big)
    NOKIA_LITTLE = 2,	// Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little)
    NOKIA_BIG = 3	// Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big)
} ReversingModes;

/*
 * Prototypes for local procedures defined in this file:
 */

static void		DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    Tcl_Obj *src, unsigned char **cursorPtr);
static void		FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static bool		GetFormatSpec(const char **formatPtr, char *cmdPtr,
			    Tcl_Size *countPtr, int *flagsPtr);
static Tcl_Obj *	ScanNumber(unsigned char *buffer, int type,
			    int flags, Tcl_HashTable **numberCachePtr);
static int		SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Size limit,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static ReversingModes	NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    size_t length, int type);
/* Binary ensemble commands */
static Tcl_ObjCmdProc	BinaryFormatCmd;
static Tcl_ObjCmdProc	BinaryScanCmd;
/* Binary encoding sub-ensemble commands */
static Tcl_ObjCmdProc	BinaryEncodeHex;
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
	( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
	? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
	: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)

int

TclIsPureByteArray(
    Tcl_Obj * objPtr)
{
    return TclHasInternalRep(objPtr, &properByteArrayType);
}

/*







<
>







195
196
197
198
199
200
201

202
203
204
205
206
207
208
209
	( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
	? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
	: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
		(irPtr)->twoPtrValue.ptr1 = (baPtr)


bool
TclIsPureByteArray(
    Tcl_Obj * objPtr)
{
    return TclHasInternalRep(objPtr, &properByteArrayType);
}

/*
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
 *	This function parses the format strings used in the binary format and
 *	scan commands.
 *
 * Results:
 *	Moves the formatPtr to the start of the next command. Returns the
 *	current command character and count in cmdPtr and countPtr. The count
 *	is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
 *	if no count was specified. Returns 1 on success, or 0 if the string
 *	did not have a format specifier.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(
    const char **formatPtr,	/* Pointer to format string. */
    char *cmdPtr,		/* Pointer to location of command char. */
    Tcl_Size *countPtr,		/* Pointer to repeat count value. */
    int *flagsPtr)		/* Pointer to field flags */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
    }

    /*
     * The string was empty, except for whitespace, so fail.
     */

    if (!(**formatPtr)) {
	return 0;
    }

    /*
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;







|
|







|



















|







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
 *	This function parses the format strings used in the binary format and
 *	scan commands.
 *
 * Results:
 *	Moves the formatPtr to the start of the next command. Returns the
 *	current command character and count in cmdPtr and countPtr. The count
 *	is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
 *	if no count was specified. Returns true on success, or false if the
 *	string did not have a format specifier.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
GetFormatSpec(
    const char **formatPtr,	/* Pointer to format string. */
    char *cmdPtr,		/* Pointer to location of command char. */
    Tcl_Size *countPtr,		/* Pointer to repeat count value. */
    int *flagsPtr)		/* Pointer to field flags */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
    }

    /*
     * The string was empty, except for whitespace, so fail.
     */

    if (!(**formatPtr)) {
	return false;
    }

    /*
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
	    *countPtr = TCL_SIZE_MAX;
	} else {
	    *countPtr = count;
	}
    } else {
	*countPtr = BINARY_NOCOUNT;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *







|







1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
	    *countPtr = TCL_SIZE_MAX;
	} else {
	    *countPtr = count;
	}
    } else {
	*countPtr = BINARY_NOCOUNT;
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static int
NeedReversing(
    int format)
{
    switch (format) {
	/* native floats and doubles: never reverse */
    case 'd':
    case 'f':







|







1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static ReversingModes
NeedReversing(
    int format)
{
    switch (format) {
	/* native floats and doubles: never reverse */
    case 'd':
    case 'f':
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
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
	/* f: reverse if we're little-endian */
    case 'Q':
    case 'R':
#else /* !WORDS_BIGENDIAN */
	/* small endian floats: reverse if we're big-endian */
    case 'r':
#endif /* WORDS_BIGENDIAN */
	return 0;

#ifdef WORDS_BIGENDIAN
	/* small endian floats: reverse if we're big-endian */
    case 'q':
    case 'r':
#else /* !WORDS_BIGENDIAN */
	/* native ints: reverse if we're little-endian */
    case 'n':
    case 't':
    case 'm':
	/* f: reverse if we're little-endian */
    case 'R':
#endif /* WORDS_BIGENDIAN */
	/* small endian ints: always reverse */
    case 'i':
    case 's':
    case 'w':
	return 1;

#ifndef WORDS_BIGENDIAN
    /*
     * The Q and q formats need special handling to account for the unusual
     * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
     * little-endian, but also reverse word order.
     */

    case 'Q':
	if (TclNokia770Doubles()) {
	    return 3;
	}
	return 1;
    case 'q':
	if (TclNokia770Doubles()) {
	    return 2;
	}
	return 0;
#endif
    }

    Tcl_Panic("unexpected fallthrough");
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyNumber --
 *







|

















|










|

|


|

|




|







1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
	/* f: reverse if we're little-endian */
    case 'Q':
    case 'R':
#else /* !WORDS_BIGENDIAN */
	/* small endian floats: reverse if we're big-endian */
    case 'r':
#endif /* WORDS_BIGENDIAN */
	return REVERSE_NO;

#ifdef WORDS_BIGENDIAN
	/* small endian floats: reverse if we're big-endian */
    case 'q':
    case 'r':
#else /* !WORDS_BIGENDIAN */
	/* native ints: reverse if we're little-endian */
    case 'n':
    case 't':
    case 'm':
	/* f: reverse if we're little-endian */
    case 'R':
#endif /* WORDS_BIGENDIAN */
	/* small endian ints: always reverse */
    case 'i':
    case 's':
    case 'w':
	return REVERSE_YES;

#ifndef WORDS_BIGENDIAN
    /*
     * The Q and q formats need special handling to account for the unusual
     * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
     * little-endian, but also reverse word order.
     */

    case 'Q':
	if (TclNokia770Doubles()) {
	    return NOKIA_BIG;
	}
	return REVERSE_YES;
    case 'q':
	if (TclNokia770Doubles()) {
	    return NOKIA_LITTLE;
	}
	return REVERSE_NO;
#endif
    }

    Tcl_Panic("unexpected fallthrough");
    return REVERSE_NO;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyNumber --
 *
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
CopyNumber(
    const void *from,		/* source */
    void *to,			/* destination */
    size_t length,		/* Number of bytes to copy */
    int type)			/* What type of thing are we copying? */
{
    switch (NeedReversing(type)) {
    case 0:
	memcpy(to, from, length);
	break;
    case 1: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	switch (length) {
	case 4:
	    toPtr[0] = fromPtr[3];
	    toPtr[1] = fromPtr[2];







|


|







1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
CopyNumber(
    const void *from,		/* source */
    void *to,			/* destination */
    size_t length,		/* Number of bytes to copy */
    int type)			/* What type of thing are we copying? */
{
    switch (NeedReversing(type)) {
    case REVERSE_NO:
	memcpy(to, from, length);
	break;
    case REVERSE_YES: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	switch (length) {
	case 4:
	    toPtr[0] = fromPtr[3];
	    toPtr[1] = fromPtr[2];
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
	    toPtr[5] = fromPtr[2];
	    toPtr[6] = fromPtr[1];
	    toPtr[7] = fromPtr[0];
	    break;
	}
	break;
    }
    case 2: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	toPtr[0] = fromPtr[4];
	toPtr[1] = fromPtr[5];
	toPtr[2] = fromPtr[6];
	toPtr[3] = fromPtr[7];
	toPtr[4] = fromPtr[0];
	toPtr[5] = fromPtr[1];
	toPtr[6] = fromPtr[2];
	toPtr[7] = fromPtr[3];
	break;
    }
    case 3: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	toPtr[0] = fromPtr[3];
	toPtr[1] = fromPtr[2];
	toPtr[2] = fromPtr[1];
	toPtr[3] = fromPtr[0];







|













|







1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
	    toPtr[5] = fromPtr[2];
	    toPtr[6] = fromPtr[1];
	    toPtr[7] = fromPtr[0];
	    break;
	}
	break;
    }
    case NOKIA_LITTLE: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	toPtr[0] = fromPtr[4];
	toPtr[1] = fromPtr[5];
	toPtr[2] = fromPtr[6];
	toPtr[3] = fromPtr[7];
	toPtr[4] = fromPtr[0];
	toPtr[5] = fromPtr[1];
	toPtr[6] = fromPtr[2];
	toPtr[7] = fromPtr[3];
	break;
    }
    case NOKIA_BIG: {
	const unsigned char *fromPtr = (const unsigned char *)from;
	unsigned char *toPtr = (unsigned char *)to;

	toPtr[0] = fromPtr[3];
	toPtr[1] = fromPtr[2];
	toPtr[2] = fromPtr[1];
	toPtr[3] = fromPtr[0];
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
	 */
    case 'w':
    case 'W':
    case 'm':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 32);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 40);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 48);







|







2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
	 */
    case 'w':
    case 'W':
    case 'm':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type) != REVERSE_NO) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 32);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 40);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 48);
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
	 */
    case 'i':
    case 'I':
    case 'n':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);







|







2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
	 */
    case 'i':
    case 'I':
    case 'n':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type) != REVERSE_NO) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 24);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 16);
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
	 */
    case 's':
    case 'S':
    case 't':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type)) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue);
	}
	return TCL_OK;







|







2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
	 */
    case 's':
    case 'S':
    case 't':
	if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (NeedReversing(type) != REVERSE_NO) {
	    *(*cursorPtr)++ = UCHAR(wvalue);
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	} else {
	    *(*cursorPtr)++ = UCHAR(wvalue >> 8);
	    *(*cursorPtr)++ = UCHAR(wvalue);
	}
	return TCL_OK;
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
	 * 16-bit numeric values. We need the sign extension trick (see above)
	 * here as well.
	 */

    case 's':
    case 'S':
    case 't':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] + (buffer[1] << 8));
	} else {
	    value = (long) (buffer[1] + (buffer[0] << 8));
	}
	if (!(flags & BINARY_UNSIGNED)) {
	    if (value & 0x8000) {
		value |= -0x10000;
	    }
	}
	goto returnNumericObject;

	/*
	 * 32-bit numeric values.
	 */

    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0]
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (((unsigned long)buffer[3]) << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)







|


















|







2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
	 * 16-bit numeric values. We need the sign extension trick (see above)
	 * here as well.
	 */

    case 's':
    case 'S':
    case 't':
	if (NeedReversing(type) != REVERSE_NO) {
	    value = (long) (buffer[0] + (buffer[1] << 8));
	} else {
	    value = (long) (buffer[1] + (buffer[0] << 8));
	}
	if (!(flags & BINARY_UNSIGNED)) {
	    if (value & 0x8000) {
		value |= -0x10000;
	    }
	}
	goto returnNumericObject;

	/*
	 * 32-bit numeric values.
	 */

    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(type) != REVERSE_NO) {
	    value = (long) (buffer[0]
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (((unsigned long)buffer[3]) << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
	 * Do not cache wide (64-bit) values; they are already too large to
	 * use as keys.
	 */

    case 'w':
    case 'W':
    case 'm':
	if (NeedReversing(type)) {
	    uwvalue = ((Tcl_WideUInt) buffer[0])
		    | (((Tcl_WideUInt) buffer[1]) << 8)
		    | (((Tcl_WideUInt) buffer[2]) << 16)
		    | (((Tcl_WideUInt) buffer[3]) << 24)
		    | (((Tcl_WideUInt) buffer[4]) << 32)
		    | (((Tcl_WideUInt) buffer[5]) << 40)
		    | (((Tcl_WideUInt) buffer[6]) << 48)







|







2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
	 * Do not cache wide (64-bit) values; they are already too large to
	 * use as keys.
	 */

    case 'w':
    case 'W':
    case 'm':
	if (NeedReversing(type) != REVERSE_NO) {
	    uwvalue = ((Tcl_WideUInt) buffer[0])
		    | (((Tcl_WideUInt) buffer[1]) << 8)
		    | (((Tcl_WideUInt) buffer[2]) << 16)
		    | (((Tcl_WideUInt) buffer[3]) << 24)
		    | (((Tcl_WideUInt) buffer[4]) << 32)
		    | (((Tcl_WideUInt) buffer[5]) << 40)
		    | (((Tcl_WideUInt) buffer[6]) << 48)
Changes to generic/tclClock.c.
2912
2913
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
2947
2948
2949
 *
 * IsGregorianLeapYear --
 *
 *	Tests whether a given year is a leap year, in either Julian or
 *	Gregorian calendar.
 *
 * Results:
 *	Returns 1 for a leap year, 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

int

IsGregorianLeapYear(
    TclDateFields *fields)	/* Date to test */
{
    Tcl_WideInt year = fields->year;

    if (fields->isBce) {
	year = 1 - year;
    }
    if (year % 4 != 0) {
	return 0;
    } else if (!(fields->gregorian)) {
	return 1;
    } else if (year % 400 == 0) {
	return 1;
    } else if (year % 100 == 0) {
	return 0;
    } else {
	return 1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WeekdayOnOrBefore --







|




<
>









|

|

|

|

|







2912
2913
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
2947
2948
2949
 *
 * IsGregorianLeapYear --
 *
 *	Tests whether a given year is a leap year, in either Julian or
 *	Gregorian calendar.
 *
 * Results:
 *	Returns true for a leap year, false otherwise.
 *
 *----------------------------------------------------------------------
 */


bool
IsGregorianLeapYear(
    TclDateFields *fields)	/* Date to test */
{
    Tcl_WideInt year = fields->year;

    if (fields->isBce) {
	year = 1 - year;
    }
    if (year % 4 != 0) {
	return false;
    } else if (!(fields->gregorian)) {
	return true;
    } else if (year % 400 == 0) {
	return true;
    } else if (year % 100 == 0) {
	return false;
    } else {
	return true;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WeekdayOnOrBefore --
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
ClockValidDate(
    DateInfo *info,		/* Clock scan info structure */
    ClockFmtScnCmdArgs *opts,	/* Scan options */
    int stage)			/* Stage to validate (1, 2 or 3 for both) */
{
    const char *errMsg = "", *errCode = "";
    TclDateFields temp;
    int tempCpyFlg = 0;
    ClockClientData *dataPtr = opts->dataPtr;

#if 0
    printf("yyMonth %d, yyDay %d, yyDayOfYear %d, yyHour %d, yyMinutes %d, yySeconds %" TCL_LL_MODIFIER "d, "
	    "yySecondOfDay %" TCL_LL_MODIFIER "d, sec %" TCL_LL_MODIFIER "d, daySec %" TCL_LL_MODIFIER "d, tzOffset %d\n",
	    yyMonth, yyDay, yydate.dayOfYear, yyHour, yyMinutes, yySeconds,
	    yySecondOfDay, yydate.localSeconds, yydate.localSeconds % SECONDS_PER_DAY,







|







3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
ClockValidDate(
    DateInfo *info,		/* Clock scan info structure */
    ClockFmtScnCmdArgs *opts,	/* Scan options */
    int stage)			/* Stage to validate (1, 2 or 3 for both) */
{
    const char *errMsg = "", *errCode = "";
    TclDateFields temp;
    bool tempCpyFlg = false;
    ClockClientData *dataPtr = opts->dataPtr;

#if 0
    printf("yyMonth %d, yyDay %d, yyDayOfYear %d, yyHour %d, yyMinutes %d, yySeconds %" TCL_LL_MODIFIER "d, "
	    "yySecondOfDay %" TCL_LL_MODIFIER "d, sec %" TCL_LL_MODIFIER "d, daySec %" TCL_LL_MODIFIER "d, tzOffset %d\n",
	    yyMonth, yyDay, yydate.dayOfYear, yyHour, yyMinutes, yySeconds,
	    yySecondOfDay, yydate.localSeconds, yydate.localSeconds % SECONDS_PER_DAY,
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
    }

    /* mmdd !~ ddd */
    if ((info->flags & (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH))
	    == (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH)) {
	if (!tempCpyFlg) {
	    memcpy(&temp, &yydate, sizeof(temp));
	    tempCpyFlg = 1;
	}
	GetJulianDayFromEraYearDay(&temp, GREGORIAN_CHANGE_DATE);
	if (temp.julianDay != yydate.julianDay) {
	    errMsg = "ambiguous day";
	    errCode = "day";
	    goto error;
	}







|







3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
    }

    /* mmdd !~ ddd */
    if ((info->flags & (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH))
	    == (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH)) {
	if (!tempCpyFlg) {
	    memcpy(&temp, &yydate, sizeof(temp));
	    tempCpyFlg = true;
	}
	GetJulianDayFromEraYearDay(&temp, GREGORIAN_CHANGE_DATE);
	if (temp.julianDay != yydate.julianDay) {
	    errMsg = "ambiguous day";
	    errCode = "day";
	    goto error;
	}
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
	}
    }

    /* day of week */
    if (info->flags & CLF_DAYOFWEEK) {
	if (!tempCpyFlg) {
	    memcpy(&temp, &yydate, sizeof(temp));
	    tempCpyFlg = 1;
	}
	GetYearWeekDay(&temp, GREGORIAN_CHANGE_DATE);
	if (temp.dayOfWeek != yyDayOfWeek) {
	    errMsg = "invalid day of week";
	    errCode = "day of week";
	    goto error;
	}







|







3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
	}
    }

    /* day of week */
    if (info->flags & CLF_DAYOFWEEK) {
	if (!tempCpyFlg) {
	    memcpy(&temp, &yydate, sizeof(temp));
	    tempCpyFlg = true;
	}
	GetYearWeekDay(&temp, GREGORIAN_CHANGE_DATE);
	if (temp.dayOfWeek != yyDayOfWeek) {
	    errMsg = "invalid day of week";
	    errCode = "day of week";
	    goto error;
	}
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
	int returnLevel;	/* corresponding field of the Interp */
	int returnCode;		/* struct. These fields taken together are */
	Tcl_Obj *errorInfo;	/* the "state" of the interp. */
	Tcl_Obj *errorCode;
	Tcl_Obj *returnOpts;
	Tcl_Obj *objResult;
	Tcl_Obj *errorStack;
	int resetErrorStack;
    } InterpState;

    Interp *iPtr = (Interp *)interp;
    int flags = 0;

    if (objc == 1) {
	/* wrong # args : */







|







4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
	int returnLevel;	/* corresponding field of the Interp */
	int returnCode;		/* struct. These fields taken together are */
	Tcl_Obj *errorInfo;	/* the "state" of the interp. */
	Tcl_Obj *errorCode;
	Tcl_Obj *returnOpts;
	Tcl_Obj *objResult;
	Tcl_Obj *errorStack;
	bool resetErrorStack;
    } InterpState;

    Interp *iPtr = (Interp *)interp;
    int flags = 0;

    if (objc == 1) {
	/* wrong # args : */
Changes to generic/tclCmdAH.c.
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    int objc = PTR2INT(data[0]);
    Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
    Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
    int rewind = iPtr->execEnvPtr->rewind;

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (rewind || Tcl_LimitExceeded(interp)) {
	TclAppendPrintfToErrorInfo(interp,







|







202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    int objc = PTR2INT(data[0]);
    Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
    Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
    bool rewind = iPtr->execEnvPtr->rewind;

    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (rewind || Tcl_LimitExceeded(interp)) {
	TclAppendPrintfToErrorInfo(interp,
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
    int objc,
    Tcl_Obj *const objv[])
{
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1, 0));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * PathNativeNameCmd --







|







1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
    int objc,
    Tcl_Obj *const objv[])
{
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1, false));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * PathNativeNameCmd --
Changes to generic/tclCmdMZ.c.
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
		&index) != TCL_OK) {
	    goto optionError;
	}
	switch (index) {
	case REGEXP_ALL:
	    all = true;
	    break;
	case REGEXP_INDICES:
	    indices = true;
	    break;
	case REGEXP_INLINE:
	    doinline = true;
	    break;







|







178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
	}
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
		&index) != TCL_OK) {
	    goto optionError;
	}
	switch (index) {
	case REGEXP_ALL:
	    all = 1;
	    break;
	case REGEXP_INDICES:
	    indices = true;
	    break;
	case REGEXP_INLINE:
	    doinline = true;
	    break;
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030


2031
2032
2033
2034
2035
2036
2037
StringMapCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2,  mapElemc;
    int nocase = 0, mapWithDict = 0, copySource = 0;
    Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
    Tcl_UniChar *ustring1, *ustring2, *p, *end;
    int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, size_t);

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	const char *string = TclGetStringFromObj(objv[1], &length2);

	if ((length2 > 1) &&
		strncmp(string, "-nocase", length2) == 0) {
	    nocase = 1;
	} else {
	    TclPrintfResult(interp, "bad option \"%s\": must be %s",
		    string, "-nocase");
	    TclSetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string);
	    return TCL_ERROR;
	}
    }

    /*
     * This test is tricky, but has to be that way or you get other strange
     * inconsistencies (see test string-10.20.1 for illustration why!)
     */

    if (!TclHasStringRep(objv[objc-2])
	    && TclHasInternalRep(objv[objc-2], &tclDictType)) {
	Tcl_Size i;
	int done;
	Tcl_DictSearch search;

	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */

	Tcl_DictObjSize(interp, objv[objc-2], &i);
	if (i == 0) {
	    /*
	     * Empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	}

	mapElemc = 2 * i;
	mapWithDict = 1;

	/*
	 * Copy the dictionary out into an array; that's the easiest way to
	 * adapt this code...
	 */

	mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);


	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		mapElemv+1, &done);
	for (Tcl_Size index=2 ; index<mapElemc ; index+=2) {
	    Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
	}
	Tcl_DictObjDone(&search);
    } else {







|














|

















<
<

















|







>
>







1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003


2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
StringMapCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Size length1, length2,  mapElemc;
    bool nocase = false, mapWithDict = false, copySource = false;
    Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
    Tcl_UniChar *ustring1, *ustring2, *p, *end;
    int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, size_t);

    if (objc < 3 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
	return TCL_ERROR;
    }

    if (objc == 4) {
	const char *string = TclGetStringFromObj(objv[1], &length2);

	if ((length2 > 1) &&
		strncmp(string, "-nocase", length2) == 0) {
	    nocase = true;
	} else {
	    TclPrintfResult(interp, "bad option \"%s\": must be %s",
		    string, "-nocase");
	    TclSetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
		    string);
	    return TCL_ERROR;
	}
    }

    /*
     * This test is tricky, but has to be that way or you get other strange
     * inconsistencies (see test string-10.20.1 for illustration why!)
     */

    if (!TclHasStringRep(objv[objc-2])
	    && TclHasInternalRep(objv[objc-2], &tclDictType)) {
	Tcl_Size i;



	/*
	 * We know the type exactly, so all dict operations will succeed for
	 * sure. This shortens this code quite a bit.
	 */

	Tcl_DictObjSize(interp, objv[objc-2], &i);
	if (i == 0) {
	    /*
	     * Empty charMap, just return whatever string was given.
	     */

	    Tcl_SetObjResult(interp, objv[objc-1]);
	    return TCL_OK;
	}

	mapElemc = 2 * i;
	mapWithDict = true;

	/*
	 * Copy the dictionary out into an array; that's the easiest way to
	 * adapt this code...
	 */

	mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
	int done;
	Tcl_DictSearch search;
	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
		mapElemv+1, &done);
	for (Tcl_Size index=2 ; index<mapElemc ; index+=2) {
	    Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done);
	}
	Tcl_DictObjDone(&search);
    } else {
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
    /*
     * Take a copy of the source string object if it is the same as the map
     * string to cut out nasty sharing crashes. [Bug 1018562]
     */

    if (objv[objc-2] == objv[objc-1]) {
	sourceObj = Tcl_DuplicateObj(objv[objc-1]);
	copySource = 1;
    } else {
	sourceObj = objv[objc-1];
    }
    ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
    if (length1 == 0) {
	/*
	 * Empty input string, just stop now.







|







2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
    /*
     * Take a copy of the source string object if it is the same as the map
     * string to cut out nasty sharing crashes. [Bug 1018562]
     */

    if (objv[objc-2] == objv[objc-1]) {
	sourceObj = Tcl_DuplicateObj(objv[objc-1]);
	copySource = true;
    } else {
	sourceObj = objv[objc-1];
    }
    ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
    if (length1 == 0) {
	/*
	 * Empty input string, just stop now.
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
	    objv, INT2PTR(objc));
    return TclNREvalObjEx(interp, bodyObj, 0,
	    ((Interp *) interp)->cmdFramePtr, 1);

  freeHandlersOnError:
    for (i=0; i<handlerCount; i++) {
	if (handlers[i].resultVar) {
	    Tcl_IncrRefCount(handlers[i].resultVar);
	}
	if (handlers[i].optionsVar) {
	    Tcl_IncrRefCount(handlers[i].optionsVar);
	}
    }
    TclStackFree(interp, (void *) handlers);
    return TCL_ERROR;
}

/*







|


|







4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
	    objv, INT2PTR(objc));
    return TclNREvalObjEx(interp, bodyObj, 0,
	    ((Interp *) interp)->cmdFramePtr, 1);

  freeHandlersOnError:
    for (i=0; i<handlerCount; i++) {
	if (handlers[i].resultVar) {
	    TclDecrRefCount(handlers[i].resultVar);
	}
	if (handlers[i].optionsVar) {
	    TclDecrRefCount(handlers[i].optionsVar);
	}
    }
    TclStackFree(interp, (void *) handlers);
    return TCL_ERROR;
}

/*
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
static inline void
ReleaseHandlers(
    Tcl_Interp *interp,
    TryHandler *handlers)
{
    for (TryHandler *handler=handlers; handler->type; handler++) {
	if (handler->resultVar) {
	    Tcl_DecrRefCount(handler->resultVar);
	}
	if (handler->optionsVar) {
	    Tcl_DecrRefCount(handler->optionsVar);
	}
    }
    TclStackFree(interp, (void*) handlers);
}

static int
TryPostBody(







|


|







4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
static inline void
ReleaseHandlers(
    Tcl_Interp *interp,
    TryHandler *handlers)
{
    for (TryHandler *handler=handlers; handler->type; handler++) {
	if (handler->resultVar) {
	    TclDecrRefCount(handler->resultVar);
	}
	if (handler->optionsVar) {
	    TclDecrRefCount(handler->optionsVar);
	}
    }
    TclStackFree(interp, (void*) handlers);
}

static int
TryPostBody(
Changes to generic/tclCompCmdsGR.c.
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
     * Get the regexp string. If it is not a simple string or can't be
     * converted to a glob pattern, push the word for the INST_REGEXP.
     * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
     */

    varTokenPtr = TokenAfter(varTokenPtr);

    int exact = 0;
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	const char *str = varTokenPtr[1].start;
	Tcl_Size len = varTokenPtr[1].size;

	/*
	 * If it has a '-', it could be an incorrectly formed regexp command.
	 */







|







2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
     * Get the regexp string. If it is not a simple string or can't be
     * converted to a glob pattern, push the word for the INST_REGEXP.
     * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
     */

    varTokenPtr = TokenAfter(varTokenPtr);

    bool exact = false;
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	const char *str = varTokenPtr[1].start;
	Tcl_Size len = varTokenPtr[1].size;

	/*
	 * If it has a '-', it could be an incorrectly formed regexp command.
	 */
2523
2524
2525
2526
2527
2528
2529

2530
2531
2532
2533
2534
2535
2536
2537
     * The only optional part is the "--", and no other options are handled.
     */

    DefineLineInformation;	/* TIP #280 */
    Tcl_Size numWords = parsePtr->numWords;
    Tcl_Token *tokenPtr, *stringTokenPtr;
    Tcl_Obj *patternObj = NULL, *replacementObj = NULL;

    int exact, quantified, result = TCL_ERROR;

    if (numWords < 5 || numWords > 6) {
	return TCL_ERROR;
    }

    /*
     * Parse the "-all", which must be the first argument (other options not







>
|







2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
     * The only optional part is the "--", and no other options are handled.
     */

    DefineLineInformation;	/* TIP #280 */
    Tcl_Size numWords = parsePtr->numWords;
    Tcl_Token *tokenPtr, *stringTokenPtr;
    Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
    bool exact, quantified;
    int result = TCL_ERROR;

    if (numWords < 5 || numWords > 6) {
	return TCL_ERROR;
    }

    /*
     * Parse the "-all", which must be the first argument (other options not
Changes to generic/tclCompCmdsSZ.c.
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
    Tcl_Size contJumpIdx;	/* Where the first of the jumps due to a group
				 * of continuation bodies starts, or -1 if
				 * there aren't any. */
    Tcl_Size contJumpCount;	/* Number of continuation bodies pointing to
				 * the current (or next) real body. */
    Tcl_Size nextArmFixupIndex;	/* Index of next issued arm to fix the jump to
				 * the next test for, or -1 if no fix pending. */
    bool simple;
    int exact;

    /*
     * Generate a test for each arm.
     */

    contJumpIdx = NO_PENDING_JUMP;
    contJumpCount = 0;







|
<







2080
2081
2082
2083
2084
2085
2086
2087

2088
2089
2090
2091
2092
2093
2094
    Tcl_Size contJumpIdx;	/* Where the first of the jumps due to a group
				 * of continuation bodies starts, or -1 if
				 * there aren't any. */
    Tcl_Size contJumpCount;	/* Number of continuation bodies pointing to
				 * the current (or next) real body. */
    Tcl_Size nextArmFixupIndex;	/* Index of next issued arm to fix the jump to
				 * the next test for, or -1 if no fix pending. */
    bool simple, exact;


    /*
     * Generate a test for each arm.
     */

    contJumpIdx = NO_PENDING_JUMP;
    contJumpCount = 0;
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
	    case Switch_Glob:
		TclCompileTokens(interp, arm->valueToken, 1,	envPtr);
		OP4(		OVER, 1);
		OP1(		STR_MATCH, noCase);
		break;
	    case Switch_Regexp:
		simple = false;
		exact = 0;

		/*
		 * Keep in sync with TclCompileRegexpCmd.
		 */

		if (arms[i].valueToken->type == TCL_TOKEN_TEXT) {
		    if (arms[i].valueToken->size == 0) {







|







2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
	    case Switch_Glob:
		TclCompileTokens(interp, arm->valueToken, 1,	envPtr);
		OP4(		OVER, 1);
		OP1(		STR_MATCH, noCase);
		break;
	    case Switch_Regexp:
		simple = false;
		exact = false;

		/*
		 * Keep in sync with TclCompileRegexpCmd.
		 */

		if (arms[i].valueToken->type == TCL_TOKEN_TEXT) {
		    if (arms[i].valueToken->size == 0) {
Changes to generic/tclCompile.c.
2023
2024
2025
2026
2027
2028
2029
2030

2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
 *	When returning true, appends the known value of the word to the
 *	unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
 *	NB: Does *NOT* manipulate the refCount of valuePtr.
 *
 *----------------------------------------------------------------------
 */

int

TclWordKnownAtCompileTime(
    Tcl_Token *tokenPtr,	/* Points to Tcl_Token we should check */
    Tcl_Obj *valuePtr)		/* If not NULL, points to an unshared Tcl_Obj
				 * to which we should append the known value
				 * of the word. */
{
    Tcl_Size numComponents = tokenPtr->numComponents;
    Tcl_Obj *tempPtr = NULL;

    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	if (valuePtr != NULL) {
	    Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size);
	}
	return 1;
    }
    if (tokenPtr->type != TCL_TOKEN_WORD) {
	return 0;
    }
    tokenPtr++;
    if (valuePtr != NULL) {
	TclNewObj(tempPtr);
	Tcl_IncrRefCount(tempPtr);
    }
    while (numComponents--) {







<
>













|


|







2023
2024
2025
2026
2027
2028
2029

2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
 *	When returning true, appends the known value of the word to the
 *	unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
 *	NB: Does *NOT* manipulate the refCount of valuePtr.
 *
 *----------------------------------------------------------------------
 */


bool
TclWordKnownAtCompileTime(
    Tcl_Token *tokenPtr,	/* Points to Tcl_Token we should check */
    Tcl_Obj *valuePtr)		/* If not NULL, points to an unshared Tcl_Obj
				 * to which we should append the known value
				 * of the word. */
{
    Tcl_Size numComponents = tokenPtr->numComponents;
    Tcl_Obj *tempPtr = NULL;

    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	if (valuePtr != NULL) {
	    Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size);
	}
	return true;
    }
    if (tokenPtr->type != TCL_TOKEN_WORD) {
	return false;
    }
    tokenPtr++;
    if (valuePtr != NULL) {
	TclNewObj(tempPtr);
	Tcl_IncrRefCount(tempPtr);
    }
    while (numComponents--) {
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
	    }
	    break;

	default:
	    if (tempPtr != NULL) {
		Tcl_DecrRefCount(tempPtr);
	    }
	    return 0;
	}
	tokenPtr++;
    }
    if (valuePtr != NULL) {
	Tcl_AppendObjToObj(valuePtr, tempPtr);
	Tcl_DecrRefCount(tempPtr);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileScript --
 *
 *	Compiles a Tcl script in a string.
 *
 * Results:
 *
 *	A standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *
 * Side effects:
 *	Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

static int
ExpandRequested(
    Tcl_Token *tokenPtr,
    Tcl_Size numWords)
{
    /* Determine whether any words of the command require expansion */
    while (numWords--) {
	if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
	    return 1;
	}
	tokenPtr = TokenAfter(tokenPtr);
    }
    return 0;
}

static void
CompileCmdLiteral(
    Tcl_Interp *interp,
    Tcl_Obj *cmdObj,
    CompileEnv *envPtr)







|







|




















|







|



|







2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
	    }
	    break;

	default:
	    if (tempPtr != NULL) {
		Tcl_DecrRefCount(tempPtr);
	    }
	    return false;
	}
	tokenPtr++;
    }
    if (valuePtr != NULL) {
	Tcl_AppendObjToObj(valuePtr, tempPtr);
	Tcl_DecrRefCount(tempPtr);
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileScript --
 *
 *	Compiles a Tcl script in a string.
 *
 * Results:
 *
 *	A standard Tcl result. If an error occurs, an
 *	error message is left in the interpreter's result.
 *
 * Side effects:
 *	Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

static bool
ExpandRequested(
    Tcl_Token *tokenPtr,
    Tcl_Size numWords)
{
    /* Determine whether any words of the command require expansion */
    while (numWords--) {
	if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
	    return true;
	}
	tokenPtr = TokenAfter(tokenPtr);
    }
    return false;
}

static void
CompileCmdLiteral(
    Tcl_Interp *interp,
    Tcl_Obj *cmdObj,
    CompileEnv *envPtr)
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
    JumpFixupArray *fixupArrayPtr)
				/* Points to the JumpFixupArray structure to
				 * initialize. */
{
    fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
    fixupArrayPtr->next = 0;
    fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1;
    fixupArrayPtr->mallocedArray = true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandJumpFixupArray --
 *







|







4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
    JumpFixupArray *fixupArrayPtr)
				/* Points to the JumpFixupArray structure to
				 * initialize. */
{
    fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
    fixupArrayPtr->next = 0;
    fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1;
    fixupArrayPtr->mallocedArray = false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandJumpFixupArray --
 *
4741
4742
4743
4744
4745
4746
4747
4748

4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
 *	False otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
int

TclIsEmptyToken(
    const Tcl_Token *tokenPtr)
{
    int ucs4, chLen = 0;
    const char *end = tokenPtr[1].start + tokenPtr[1].size;
    for (const char *ptr = tokenPtr[1].start; ptr < end; ptr += chLen) {
	chLen = TclUtfToUniChar(ptr, &ucs4);
	// Can't use Tcl_UniCharIsSpace; see test dict-22.24
	if (!TclIsSpaceProcM((unsigned) ucs4)) {
	    return 0;
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLocalScalarFromToken --
 *







<
>









|


|







4741
4742
4743
4744
4745
4746
4747

4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
 *	False otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

bool
TclIsEmptyToken(
    const Tcl_Token *tokenPtr)
{
    int ucs4, chLen = 0;
    const char *end = tokenPtr[1].start + tokenPtr[1].size;
    for (const char *ptr = tokenPtr[1].start; ptr < end; ptr += chLen) {
	chLen = TclUtfToUniChar(ptr, &ucs4);
	// Can't use Tcl_UniCharIsSpace; see test dict-22.24
	if (!TclIsSpaceProcM((unsigned) ucs4)) {
	    return false;
	}
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLocalScalarFromToken --
 *
Changes to generic/tclCompile.h.
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
			    Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_AuxDataRef TclCreateAuxData(void *clientData,
			    const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_ExceptionRange TclCreateExceptRange(ExceptionRangeType type,
			    CompileEnv *envPtr);
MODULE_SCOPE ExecEnv *	TclCreateExecEnv(Tcl_Interp *interp, size_t size);
MODULE_SCOPE Tcl_Obj *	TclCreateLiteral(Interp *iPtr, const char *bytes,
			    Tcl_Size length, size_t hash, int *newPtr,
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);







|







1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
			    Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_AuxDataRef TclCreateAuxData(void *clientData,
			    const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE Tcl_ExceptionRange TclCreateExceptRange(ExceptionRangeType type,
			    CompileEnv *envPtr);
MODULE_SCOPE ExecEnv *	TclCreateExecEnv(Tcl_Interp *interp, size_t size);
MODULE_SCOPE Tcl_Obj *	TclCreateLiteral(Interp *iPtr, const char *bytes,
			    Tcl_Size length, size_t hash, bool *newPtr,
			    Namespace *nsPtr, int flags,
			    LiteralEntry **globalPtrPtr);
MODULE_SCOPE void	TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void	TclDeleteLiteralTable(Tcl_Interp *interp,
			    LiteralTable *tablePtr);
MODULE_SCOPE void	TclEmitForwardJump(CompileEnv *envPtr,
			    TclJumpType jumpType, JumpFixup *jumpFixupPtr);
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
			    CompileEnv *envPtr, const char *string,
			    size_t numBytes, const CmdFrame *invoker, Tcl_Size word);
MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
			    int returnCode, ExceptionAux **auxPtrPtr);
MODULE_SCOPE int	TclIsEmptyToken(const Tcl_Token *tokenPtr);
MODULE_SCOPE void	TclAddLoopBreakFixup(CompileEnv *envPtr,
			    ExceptionAux *auxPtr);
MODULE_SCOPE void	TclAddLoopContinueFixup(CompileEnv *envPtr,
			    ExceptionAux *auxPtr);
MODULE_SCOPE void	TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
			    Tcl_Size range);
#ifdef TCL_COMPILE_STATS







|







1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
			    CompileEnv *envPtr, const char *string,
			    size_t numBytes, const CmdFrame *invoker, Tcl_Size word);
MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
			    int returnCode, ExceptionAux **auxPtrPtr);
MODULE_SCOPE bool	TclIsEmptyToken(const Tcl_Token *tokenPtr);
MODULE_SCOPE void	TclAddLoopBreakFixup(CompileEnv *envPtr,
			    ExceptionAux *auxPtr);
MODULE_SCOPE void	TclAddLoopContinueFixup(CompileEnv *envPtr,
			    ExceptionAux *auxPtr);
MODULE_SCOPE void	TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
			    Tcl_Size range);
#ifdef TCL_COMPILE_STATS
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
MODULE_SCOPE Tcl_ObjCmdProc	TclSortingOpCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclVariadicOpCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclNoIdentOpCmd;
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void	TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE int	TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
			    Tcl_Obj *valuePtr);
MODULE_SCOPE void	TclLogCommandInfo(Tcl_Interp *interp,
			    const char *script, const char *command,
			    Tcl_Size length, const unsigned char *pc,
			    Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *	TclGetInnerContext(Tcl_Interp *interp,
			    const unsigned char *pc, Tcl_Obj **tosPtr);







|







1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
MODULE_SCOPE Tcl_ObjCmdProc	TclSortingOpCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclVariadicOpCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclNoIdentOpCmd;
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void	TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void	TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE bool	TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
			    Tcl_Obj *valuePtr);
MODULE_SCOPE void	TclLogCommandInfo(Tcl_Interp *interp,
			    const char *script, const char *command,
			    Tcl_Size length, const unsigned char *pc,
			    Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *	TclGetInnerContext(Tcl_Interp *interp,
			    const unsigned char *pc, Tcl_Obj **tosPtr);
Changes to generic/tclDate.h.
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

/*
 * Prototypes of module functions.
 */

MODULE_SCOPE int	ToSeconds(int Hours, int Minutes,
			    int Seconds, MERIDIAN Meridian);
MODULE_SCOPE int	IsGregorianLeapYear(TclDateFields *);
MODULE_SCOPE void	GetJulianDayFromEraYearWeekDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE void	GetJulianDayFromEraYearMonthDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE void	GetJulianDayFromEraYearDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE int	ConvertUTCToLocal(ClockClientData *dataPtr, Tcl_Interp *,







|







519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

/*
 * Prototypes of module functions.
 */

MODULE_SCOPE int	ToSeconds(int Hours, int Minutes,
			    int Seconds, MERIDIAN Meridian);
MODULE_SCOPE bool	IsGregorianLeapYear(TclDateFields *);
MODULE_SCOPE void	GetJulianDayFromEraYearWeekDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE void	GetJulianDayFromEraYearMonthDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE void	GetJulianDayFromEraYearDay(
			    TclDateFields *fields, int changeover);
MODULE_SCOPE int	ConvertUTCToLocal(ClockClientData *dataPtr, Tcl_Interp *,
Changes to generic/tclDictObj.c.
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
static void			InvalidateDictChain(Tcl_Obj *dictObj);
static Tcl_SetFromAnyProc	SetDictFromAny;
static Tcl_UpdateStringProc	UpdateStringOfDict;
static Tcl_AllocHashEntryProc	AllocChainEntry;
static inline void		InitChainTable(struct Dict *dict);
static inline void		DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry *	CreateChainEntry(struct Dict *dict,
					Tcl_Obj *keyPtr, int *newPtr);
static inline int		DeleteChainEntry(struct Dict *dict,
					Tcl_Obj *keyPtr);
static Tcl_NRPostProc		FinalizeDictUpdate;
static Tcl_NRPostProc		FinalizeDictWith;
static Tcl_ObjCmdProc		DictForNRCmd;
static Tcl_ObjCmdProc		DictMapNRCmd;
static Tcl_NRPostProc		DictForLoopCallback;
static Tcl_NRPostProc		DictMapLoopCallback;








|
|
|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
static void			InvalidateDictChain(Tcl_Obj *dictObj);
static Tcl_SetFromAnyProc	SetDictFromAny;
static Tcl_UpdateStringProc	UpdateStringOfDict;
static Tcl_AllocHashEntryProc	AllocChainEntry;
static inline void		InitChainTable(struct Dict *dict);
static inline void		DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry *	CreateChainEntry(struct Dict *dict,
				    Tcl_Obj *keyPtr, int newPtr[static 1]);
static inline bool		DeleteChainEntry(struct Dict *dict,
				    Tcl_Obj *keyPtr);
static Tcl_NRPostProc		FinalizeDictUpdate;
static Tcl_NRPostProc		FinalizeDictWith;
static Tcl_ObjCmdProc		DictForNRCmd;
static Tcl_ObjCmdProc		DictMapNRCmd;
static Tcl_NRPostProc		DictForLoopCallback;
static Tcl_NRPostProc		DictMapLoopCallback;

267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
    Tcl_DeleteHashTable(&dict->table);
}

static inline Tcl_HashEntry *
CreateChainEntry(
    Dict *dict,
    Tcl_Obj *keyPtr,
    int *newPtr)
{
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr);

    /*
     * If this is a new entry in the hash table, stitch it into the chain.
     */







|







267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
    Tcl_DeleteHashTable(&dict->table);
}

static inline Tcl_HashEntry *
CreateChainEntry(
    Dict *dict,
    Tcl_Obj *keyPtr,
    int newPtr[static 1])	// OUT: New flag. ABSOLUTELY NOT NULL!
{
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr);

    /*
     * If this is a new entry in the hash table, stitch it into the chain.
     */
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
	    dict->entryChainTail = cPtr;
	}
    }

    return &cPtr->entry;
}

static inline int
DeleteChainEntry(
    Dict *dict,
    Tcl_Obj *keyPtr)
{
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_FindHashEntry(&dict->table, keyPtr);

    if (cPtr == NULL) {
	return 0;

    } else {
	Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);

	TclDecrRefCount(valuePtr);
    }

    /*
     * Unstitch from the chain.
     */

    if (cPtr->nextPtr) {
	cPtr->nextPtr->prevPtr = cPtr->prevPtr;
    } else {
	dict->entryChainTail = cPtr->prevPtr;
    }
    if (cPtr->prevPtr) {
	cPtr->prevPtr->nextPtr = cPtr->nextPtr;
    } else {
	dict->entryChainHead = cPtr->nextPtr;
    }

    Tcl_DeleteHashEntry(&cPtr->entry);
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * DupDictInternalRep --
 *







|








|
>
|
|
<
|
<

















|







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311

312

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
	    dict->entryChainTail = cPtr;
	}
    }

    return &cPtr->entry;
}

static inline bool
DeleteChainEntry(
    Dict *dict,
    Tcl_Obj *keyPtr)
{
    ChainEntry *cPtr = (ChainEntry *)
	    Tcl_FindHashEntry(&dict->table, keyPtr);

    if (cPtr == NULL) {
	return false;
    }

    Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);

    TclDecrRefCount(valuePtr);


    /*
     * Unstitch from the chain.
     */

    if (cPtr->nextPtr) {
	cPtr->nextPtr->prevPtr = cPtr->prevPtr;
    } else {
	dict->entryChainTail = cPtr->prevPtr;
    }
    if (cPtr->prevPtr) {
	cPtr->prevPtr->nextPtr = cPtr->nextPtr;
    } else {
	dict->entryChainHead = cPtr->nextPtr;
    }

    Tcl_DeleteHashEntry(&cPtr->entry);
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * DupDictInternalRep --
 *
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
	return TCL_ERROR;
    }

    TclInvalidateStringRep(dictPtr);
    int isNew;
    Tcl_HashEntry *hPtr = CreateChainEntry(dict, keyPtr, &isNew);
    dict->refCount++;
    TclFreeInternalRep(dictPtr)
    DictSetInternalRep(dictPtr, dict);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }







|







932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
	return TCL_ERROR;
    }

    TclInvalidateStringRep(dictPtr);
    int isNew;
    Tcl_HashEntry *hPtr = CreateChainEntry(dict, keyPtr, &isNew);
    dict->refCount++;
    TclFreeInternalRep(dictPtr);
    DictSetInternalRep(dictPtr, dict);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);

	TclDecrRefCount(oldValuePtr);
    }
Changes to generic/tclEnsemble.c.
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
int
Tcl_IsEnsemble(
    Tcl_Command token)		/* The command to check. */
{
    Command *cmdPtr = (Command *) token;

    if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
	return 1;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
    if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
	return 0;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclMakeEnsemble --
 *







|



|

|







1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
int
Tcl_IsEnsemble(
    Tcl_Command token)		/* The command to check. */
{
    Command *cmdPtr = (Command *) token;

    if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
	return true;
    }
    cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
    if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
	return false;
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclMakeEnsemble --
 *
Changes to generic/tclEnv.c.
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
#if defined(_WIN32)
	if (tenviron == NULL) {
	    /*
	     * When we are started from main(), the _wenviron array could
	     * be NULL and will be initialized by the first _wgetenv() call.
	     */

	(void) _wgetenv(L"WINDIR");
	}
#endif
	TclSetEnv(name, value+1);
    }
    TclEnvEpoch++;

    Tcl_DStringFree(&nameString);







|







420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
#if defined(_WIN32)
	if (tenviron == NULL) {
	    /*
	     * When we are started from main(), the _wenviron array could
	     * be NULL and will be initialized by the first _wgetenv() call.
	     */

	    (void) _wgetenv(L"WINDIR");
	}
#endif
	TclSetEnv(name, value+1);
    }
    TclEnvEpoch++;

    Tcl_DStringFree(&nameString);
Changes to generic/tclEvent.c.
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469

int
TclInThreadExit(void)
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr == NULL) {
	return 0;
    }
    return (int) tsdPtr->inExit;
}

/*
 *----------------------------------------------------------------------
 *







|







1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469

int
TclInThreadExit(void)
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);

    if (tsdPtr == NULL) {
	return false;
    }
    return (int) tsdPtr->inExit;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclExecute.c.
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#endif /* !ASYNC_CHECK_COUNT */

/*
 * Boolean flag indicating whether the Tcl bytecode interpreter has been
 * initialized.
 */

static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)

static int cachedInExit = 0;

#ifdef TCL_COMPILE_DEBUG
/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only







|


|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#endif /* !ASYNC_CHECK_COUNT */

/*
 * Boolean flag indicating whether the Tcl bytecode interpreter has been
 * initialized.
 */

static bool execInitialized = false;
TCL_DECLARE_MUTEX(execMutex)

static bool cachedInExit = false;

#ifdef TCL_COMPILE_DEBUG
/*
 * Variable that controls whether execution tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no execution tracing
 *    1: trace invocations of Tcl procs only
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
/* Verify the stack depth, only when no expansion is in progress */

#ifdef TCL_COMPILE_DEBUG
#define CHECK_STACK() \
    do {								\
	ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH,			\
		/*checkStack*/ !(starting || auxObjList));		\
	starting = 0;							\
    } while (0)
#else
#define CHECK_STACK()
#endif // TCL_COMPILE_DEBUG

#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
    do {								\







|







200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
/* Verify the stack depth, only when no expansion is in progress */

#ifdef TCL_COMPILE_DEBUG
#define CHECK_STACK() \
    do {								\
	ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH,			\
		/*checkStack*/ !(starting || auxObjList));		\
	starting = false;							\
    } while (0)
#else
#define CHECK_STACK()
#endif // TCL_COMPILE_DEBUG

#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
    do {								\
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
 * pair must surround any call inside TclNRExecuteByteCode (and a few other
 * procedures that use this scheme) that could result in a recursive call
 * to TclNRExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    checkInterp = 1

#define DECACHE_STACK_INFO() \
    esPtr->tosPtr = tosPtr

/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another







|







386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
 * pair must surround any call inside TclNRExecuteByteCode (and a few other
 * procedures that use this scheme) that could result in a recursive call
 * to TclNRExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    checkInterp = true

#define DECACHE_STACK_INFO() \
    esPtr->tosPtr = tosPtr

/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
    TclNewIntObj(eePtr->constants[0], 0);
    Tcl_IncrRefCount(eePtr->constants[0]);
    TclNewIntObj(eePtr->constants[1], 1);
    Tcl_IncrRefCount(eePtr->constants[1]);
    eePtr->interp = interp;
    eePtr->callbackPtr = NULL;
    eePtr->corPtr = NULL;
    eePtr->rewind = 0;

    esPtr->prevPtr = NULL;
    esPtr->nextPtr = NULL;
    esPtr->markerPtr = NULL;
    esPtr->endPtr = &esPtr->stackWords[size - 1];
    esPtr->tosPtr = STACK_BASE(esPtr);

    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	InitByteCodeExecution(interp);
	execInitialized = 1;
    }
    Tcl_MutexUnlock(&execMutex);

    return eePtr;
}

/*







|










|







865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
    TclNewIntObj(eePtr->constants[0], 0);
    Tcl_IncrRefCount(eePtr->constants[0]);
    TclNewIntObj(eePtr->constants[1], 1);
    Tcl_IncrRefCount(eePtr->constants[1]);
    eePtr->interp = interp;
    eePtr->callbackPtr = NULL;
    eePtr->corPtr = NULL;
    eePtr->rewind = false;

    esPtr->prevPtr = NULL;
    esPtr->nextPtr = NULL;
    esPtr->markerPtr = NULL;
    esPtr->endPtr = &esPtr->stackWords[size - 1];
    esPtr->tosPtr = STACK_BASE(esPtr);

    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	InitByteCodeExecution(interp);
	execInitialized = true;
    }
    Tcl_MutexUnlock(&execMutex);

    return eePtr;
}

/*
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
 *----------------------------------------------------------------------
 */

void
TclFinalizeExecution(void)
{
    Tcl_MutexLock(&execMutex);
    execInitialized = 0;
    Tcl_MutexUnlock(&execMutex);
}

/*
 * Auxiliary code to insure that GrowEvaluationStack always returns correctly
 * aligned memory.
 *







|







971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
 *----------------------------------------------------------------------
 */

void
TclFinalizeExecution(void)
{
    Tcl_MutexLock(&execMutex);
    execInitialized = false;
    Tcl_MutexUnlock(&execMutex);
}

/*
 * Auxiliary code to insure that GrowEvaluationStack always returns correctly
 * aligned memory.
 *
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    Tcl_Size cleanup = PTR2INT(data[2]);
    Tcl_Obj *objResultPtr;
    int checkInterp = 0;	/* Indicates when a check of interp readyness
				 * is necessary. Set by CACHE_STACK_INFO() */

    /*
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now mostly defined locally where needed.
     */

    Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
    Tcl_Obj **objv = NULL;
    Tcl_Size length, objc = 0, varIdx, numArgs;
    unsigned tblIdx;
    int pcAdjustment;
    Var *varPtr, *arrayPtr;

#ifdef TCL_COMPILE_DEBUG
    int starting = 1;
    traceInstructions = (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_INSTRUCTIONS);
#endif

    TEBC_DATA_DIG();

#ifdef TCL_COMPILE_DEBUG
    if (!pc && (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS)) {







|
















|







2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    Tcl_Size cleanup = PTR2INT(data[2]);
    Tcl_Obj *objResultPtr;
    bool checkInterp = false;	/* Indicates when a check of interp readyness
				 * is necessary. Set by CACHE_STACK_INFO() */

    /*
     * Locals - variables that are used within opcodes or bounded sections of
     * the file (jumps between opcodes within a family).
     * NOTE: These are now mostly defined locally where needed.
     */

    Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
    Tcl_Obj **objv = NULL;
    Tcl_Size length, objc = 0, varIdx, numArgs;
    unsigned tblIdx;
    int pcAdjustment;
    Var *varPtr, *arrayPtr;

#ifdef TCL_COMPILE_DEBUG
    bool starting = true;
    traceInstructions = (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_INSTRUCTIONS);
#endif

    TEBC_DATA_DIG();

#ifdef TCL_COMPILE_DEBUG
    if (!pc && (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS)) {
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
	}
	if (iPtr->execEnvPtr->rewind) {
	    result = TCL_ERROR;
	    goto abnormalReturn;
	}
	if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
	    codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
	    checkInterp = 1;
	    iPtr->flags |= ERR_ALREADY_LOGGED;
	}

	if (result != TCL_OK) {
	    pc--;
	    goto processExceptionReturn;
	}







|







2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
	}
	if (iPtr->execEnvPtr->rewind) {
	    result = TCL_ERROR;
	    goto abnormalReturn;
	}
	if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
	    codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
	    checkInterp = true;
	    iPtr->flags |= ERR_ALREADY_LOGGED;
	}

	if (result != TCL_OK) {
	    pc--;
	    goto processExceptionReturn;
	}
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
	iPtr->cmdCount += TclGetUInt4AtPtr(pc + 5);
	if (checkInterp) {
	    if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
		    (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
		    !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
		goto instStartCmdFailed;
	    }
	    checkInterp = 0;
	}
	inst = *(pc += 9);
	goto peepholeStart;
    } else if (inst == INST_NOP) {
#ifndef TCL_COMPILE_DEBUG
	while (inst == INST_NOP)
#endif







|







2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
	iPtr->cmdCount += TclGetUInt4AtPtr(pc + 5);
	if (checkInterp) {
	    if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
		    (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
		    !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
		goto instStartCmdFailed;
	    }
	    checkInterp = false;
	}
	inst = *(pc += 9);
	goto peepholeStart;
    } else if (inst == INST_NOP) {
#ifndef TCL_COMPILE_DEBUG
	while (inst == INST_NOP)
#endif
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
	 */

	CLANG_ASSERT(auxObjList);
	objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
	POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
	/* Ugly abuse! */
	starting = 1;
#endif
	TRACE("=> drop %" SIZEd " items\n", objc);
	NEXT_INST_V(1, objc, 0);

    case INST_EXPAND_STKTOP:
	/*
	 * Make sure that the element at stackTop is a list; if not, just







|







2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
	 */

	CLANG_ASSERT(auxObjList);
	objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
	POP_TAUX_OBJ();
#ifdef TCL_COMPILE_DEBUG
	/* Ugly abuse! */
	starting = true;
#endif
	TRACE("=> drop %" SIZEd " items\n", objc);
	NEXT_INST_V(1, objc, 0);

    case INST_EXPAND_STKTOP:
	/*
	 * Make sure that the element at stackTop is a list; if not, just
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE("%u => ", (unsigned) varIdx);
	if (ReadTraced(varPtr)) {
	    DECACHE_STACK_INFO();
	    TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
		    TCL_TRACE_READS, 0, varIdx);
	    CACHE_STACK_INFO();
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, NULL);
		varPtr = NULL;
	    }
	}
	goto afterExistsPeephole;







|







4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE("%u => ", (unsigned) varIdx);
	if (ReadTraced(varPtr)) {
	    DECACHE_STACK_INFO();
	    TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
		    TCL_TRACE_READS, false, varIdx);
	    CACHE_STACK_INFO();
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, NULL);
		varPtr = NULL;
	    }
	}
	goto afterExistsPeephole;
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
	}
	varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access",
		0, 1, arrayPtr, varIdx);
	if (varPtr) {
	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
		DECACHE_STACK_INFO();
		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
			TCL_TRACE_READS, 0, varIdx);
		CACHE_STACK_INFO();
	    }
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, arrayPtr);
		varPtr = NULL;
	    }
	}







|







4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
	}
	varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access",
		0, 1, arrayPtr, varIdx);
	if (varPtr) {
	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
		DECACHE_STACK_INFO();
		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
			TCL_TRACE_READS, false, varIdx);
		CACHE_STACK_INFO();
	    }
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, arrayPtr);
		varPtr = NULL;
	    }
	}
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
    doExistStk:
	varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
		/*createPart1*/0, /*createPart2*/1, &arrayPtr);
	if (varPtr) {
	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
		DECACHE_STACK_INFO();
		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, part2Ptr,
			TCL_TRACE_READS, 0, -1);
		CACHE_STACK_INFO();
	    }
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, arrayPtr);
		varPtr = NULL;
	    }
	}







|







4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
    doExistStk:
	varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
		/*createPart1*/0, /*createPart2*/1, &arrayPtr);
	if (varPtr) {
	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
		DECACHE_STACK_INFO();
		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, part2Ptr,
			TCL_TRACE_READS, false, -1);
		CACHE_STACK_INFO();
	    }
	    if (TclIsVarUndefined(varPtr)) {
		TclCleanupVar(varPtr, arrayPtr);
		varPtr = NULL;
	    }
	}
7103
7104
7105
7106
7107
7108
7109
7110

7111
7112
7113
7114
7115
7116
7117

    /*
     * -----------------------------------------------------------------
     *	   Start of dictionary-related instructions.
     */

    {
	int allocateDict, done, allocdict;

	Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
	Tcl_Obj *emptyPtr, **keyPtrPtr;
	Tcl_DictSearch *searchPtr;
	DictUpdateInfo *duiPtr;

    case INST_DICT_VERIFY: {
	Tcl_Size size;







|
>







7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118

    /*
     * -----------------------------------------------------------------
     *	   Start of dictionary-related instructions.
     */

    {
	bool allocateDict;
	int done;
	Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
	Tcl_Obj *emptyPtr, **keyPtrPtr;
	Tcl_DictSearch *searchPtr;
	DictUpdateInfo *duiPtr;

    case INST_DICT_VERIFY: {
	Tcl_Size size;
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
		    varIdx);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = 1;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}








|







7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
		    varIdx);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = true;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}

7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
		    varIdx);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = 1;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}








|







7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
	    DECACHE_STACK_INFO();
	    dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
		    varIdx);
	    CACHE_STACK_INFO();
	}
	if (dictPtr == NULL) {
	    TclNewObj(dictPtr);
	    allocateDict = true;
	} else {
	    allocateDict = Tcl_IsShared(dictPtr);
	    if (allocateDict) {
		dictPtr = Tcl_DuplicateObj(dictPtr);
	    }
	}

7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
	}
	if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
		|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
			&keyPtrPtr) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	allocdict = Tcl_IsShared(dictPtr);
	if (allocdict) {
	    dictPtr = Tcl_DuplicateObj(dictPtr);
	}
	if (length > 0) {
	    TclInvalidateStringRep(dictPtr);
	}
	for (Tcl_Size i=0 ; i<length ; i++) {
	    Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);







|
|







7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
7672
	}
	if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
		|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
			&keyPtrPtr) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}
	allocateDict = Tcl_IsShared(dictPtr);
	if (allocateDict) {
	    dictPtr = Tcl_DuplicateObj(dictPtr);
	}
	if (length > 0) {
	    TclInvalidateStringRep(dictPtr);
	}
	for (Tcl_Size i=0 ; i<length ; i++) {
	    Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
	    varPtr->value.objPtr = dictPtr;
	} else {
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
		    dictPtr, TCL_LEAVE_ERR_MSG, varIdx);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		if (allocdict) {
		    TclDecrRefCount(dictPtr);
		}
		TRACE_ERROR(interp);
		goto gotError;
	    }
	}
	TRACE_APPEND("written back\n");







|







7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
	    varPtr->value.objPtr = dictPtr;
	} else {
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
		    dictPtr, TCL_LEAVE_ERR_MSG, varIdx);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		if (allocateDict) {
		    TclDecrRefCount(dictPtr);
		}
		TRACE_ERROR(interp);
		goto gotError;
	    }
	}
	TRACE_APPEND("written back\n");
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
	    break;
	default:
	    TCL_UNREACHABLE();
	}
	WIDE_RESULT(wResult);

    case INST_EXPON: {
	int oddExponent = 0, negativeExponent = 0;
	unsigned short base;

	if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
	    Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
	    Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);

	    if (d1==0.0 && d2<0.0) {







|







8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
	    break;
	default:
	    TCL_UNREACHABLE();
	}
	WIDE_RESULT(wResult);

    case INST_EXPON: {
	bool oddExponent = false, negativeExponent = false;
	unsigned short base;

	if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
	    Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
	    Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);

	    if (d1==0.0 && d2<0.0) {
Changes to generic/tclFCmd.c.
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
	    result = TCL_ERROR;
	    break;
	}
	Tcl_Obj *jargv[] = {
	    objv[objc - 1],
	    source
	};
	Tcl_Obj *newFileName = TclJoinPath(2, jargv, 1);
	Tcl_IncrRefCount(newFileName);
	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
		force);
	Tcl_DecrRefCount(newFileName);
	Tcl_DecrRefCount(source);

	if (result == TCL_ERROR) {







|







206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
	    result = TCL_ERROR;
	    break;
	}
	Tcl_Obj *jargv[] = {
	    objv[objc - 1],
	    source
	};
	Tcl_Obj *newFileName = TclJoinPath(2, jargv, true);
	Tcl_IncrRefCount(newFileName);
	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
		force);
	Tcl_DecrRefCount(newFileName);
	Tcl_DecrRefCount(source);

	if (result == TCL_ERROR) {
Changes to generic/tclFileName.c.
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
/*
 * Prototypes for local procedures defined in this file:
 */

static const char *	ExtractWinRoot(const char *path,
			    Tcl_DString *resultPtr, int offset,
			    Tcl_PathType *typePtr);
static int		SkipToChar(char **stringPtr, int match);
static Tcl_Obj *	SplitWinPath(const char *path);
static Tcl_Obj *	SplitUnixPath(const char *path);
static int		DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
			    const char *separators, Tcl_Obj *pathPtr, int flags,
			    char *pattern, Tcl_GlobTypeData *types);
static int		TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *pathPrefix, int globFlags,







|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
/*
 * Prototypes for local procedures defined in this file:
 */

static const char *	ExtractWinRoot(const char *path,
			    Tcl_DString *resultPtr, int offset,
			    Tcl_PathType *typePtr);
static bool		SkipToChar(char **stringPtr, int match);
static Tcl_Obj *	SplitWinPath(const char *path);
static Tcl_Obj *	SplitUnixPath(const char *path);
static int		DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
			    const char *separators, Tcl_Obj *pathPtr, int flags,
			    char *pattern, Tcl_GlobTypeData *types);
static int		TclGlob(Tcl_Interp *interp, char *pattern,
			    Tcl_Obj *pathPrefix, int globFlags,
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77
78
79
 *	any NT extended path prefixes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May modify the Tcl_DString.

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

static void
SetResultLength(
    Tcl_DString *resultPtr,
    int offset,
    int extended)
{
    Tcl_DStringSetLength(resultPtr, offset);







>


<







63
64
65
66
67
68
69
70
71
72

73
74
75
76
77
78
79
 *	any NT extended path prefixes.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May modify the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

static void
SetResultLength(
    Tcl_DString *resultPtr,
    int offset,
    int extended)
{
    Tcl_DStringSetLength(resultPtr, offset);
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
Tcl_Obj *
Tcl_FSJoinToPath(
    Tcl_Obj *pathPtr,		/* Valid path or NULL. */
    Tcl_Size objc,		/* Number of array elements to join */
    Tcl_Obj *const objv[])	/* Path elements to join. */
{
    if (pathPtr == NULL) {
	return TclJoinPath(objc, objv, 0);
    }
    if (objc == 0) {
	return TclJoinPath(1, &pathPtr, 0);
    }
    if (objc == 1) {
	Tcl_Obj *pair[] = {
	    pathPtr,
	    objv[0]
	};
	return TclJoinPath(2, pair, 0);
    } else {
	Tcl_Size elemc = objc + 1;
	Tcl_Obj **elemv = (Tcl_Obj**) Tcl_Alloc(elemc*sizeof(Tcl_Obj *));

	elemv[0] = pathPtr;
	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
	Tcl_Obj *ret = TclJoinPath(elemc, elemv, 0);
	Tcl_Free(elemv);
	return ret;
    }
}

/*
 *---------------------------------------------------------------------------







|


|






|






|







750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
Tcl_Obj *
Tcl_FSJoinToPath(
    Tcl_Obj *pathPtr,		/* Valid path or NULL. */
    Tcl_Size objc,		/* Number of array elements to join */
    Tcl_Obj *const objv[])	/* Path elements to join. */
{
    if (pathPtr == NULL) {
	return TclJoinPath(objc, objv, false);
    }
    if (objc == 0) {
	return TclJoinPath(1, &pathPtr, false);
    }
    if (objc == 1) {
	Tcl_Obj *pair[] = {
	    pathPtr,
	    objv[0]
	};
	return TclJoinPath(2, pair, false);
    } else {
	Tcl_Size elemc = objc + 1;
	Tcl_Obj **elemv = (Tcl_Obj**) Tcl_Alloc(elemc*sizeof(Tcl_Obj *));

	elemv[0] = pathPtr;
	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
	Tcl_Obj *ret = TclJoinPath(elemc, elemv, false);
	Tcl_Free(elemv);
	return ret;
    }
}

/*
 *---------------------------------------------------------------------------
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
 */

void
TclpNativeJoinPath(
    Tcl_Obj *prefix,
    const char *joining)
{
    int needsSep;
    Tcl_Size length;
    const char *start = TclGetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from drive-letter prefixed
     * elements on Windows, unless it is the first component.
     */







|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
 */

void
TclpNativeJoinPath(
    Tcl_Obj *prefix,
    const char *joining)
{
    bool needsSep;
    Tcl_Size length;
    const char *start = TclGetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from drive-letter prefixed
     * elements on Windows, unless it is the first component.
     */
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
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
	 * Append a separator if needed.
	 */

	if (length > 0 && (start[length-1] != '/')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    (void)TclGetStringFromObj(prefix, &length);
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.
	 */

	Tcl_SetObjLength(prefix, length + strlen(p));

	dest = TclGetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if (*p == '/') {
		while (p[1] == '/') {
		    p++;
		}
		if (p[1] != '\0' && needsSep) {
		    *dest++ = '/';
		}
	    } else {
		*dest++ = *p;
		needsSep = 1;
	    }
	}
	length = dest - TclGetString(prefix);
	Tcl_SetObjLength(prefix, length);
	break;

    case TCL_PLATFORM_WINDOWS:
	/*
	 * Check to see if we need to append a separator.
	 */

	if ((length > 0) &&
		(start[length-1] != '/') && (start[length-1] != ':')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    (void)TclGetStringFromObj(prefix, &length);
	}
	needsSep = 0;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.
	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));
	dest = TclGetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if ((*p == '/') || (*p == '\\')) {
		while ((p[1] == '/') || (p[1] == '\\')) {
		    p++;
		}
		if ((p[1] != '\0') && needsSep) {
		    *dest++ = '/';
		}
	    } else {
		*dest++ = *p;
		needsSep = 1;
	    }
	}
	length = dest - TclGetString(prefix);
	Tcl_SetObjLength(prefix, length);
	break;
    }
    return;







|


















|
















|

















|







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
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
	 * Append a separator if needed.
	 */

	if (length > 0 && (start[length-1] != '/')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    (void)TclGetStringFromObj(prefix, &length);
	}
	needsSep = false;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.
	 */

	Tcl_SetObjLength(prefix, length + strlen(p));

	dest = TclGetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if (*p == '/') {
		while (p[1] == '/') {
		    p++;
		}
		if (p[1] != '\0' && needsSep) {
		    *dest++ = '/';
		}
	    } else {
		*dest++ = *p;
		needsSep = true;
	    }
	}
	length = dest - TclGetString(prefix);
	Tcl_SetObjLength(prefix, length);
	break;

    case TCL_PLATFORM_WINDOWS:
	/*
	 * Check to see if we need to append a separator.
	 */

	if ((length > 0) &&
		(start[length-1] != '/') && (start[length-1] != ':')) {
	    Tcl_AppendToObj(prefix, "/", 1);
	    (void)TclGetStringFromObj(prefix, &length);
	}
	needsSep = false;

	/*
	 * Append the element, eliminating duplicate and trailing slashes.
	 */

	Tcl_SetObjLength(prefix, length + (int) strlen(p));
	dest = TclGetString(prefix) + length;
	for (; *p != '\0'; p++) {
	    if ((*p == '/') || (*p == '\\')) {
		while ((p[1] == '/') || (p[1] == '\\')) {
		    p++;
		}
		if ((p[1] != '\0') && needsSep) {
		    *dest++ = '/';
		}
	    } else {
		*dest++ = *p;
		needsSep = true;
	    }
	}
	length = dest - TclGetString(prefix);
	Tcl_SetObjLength(prefix, length);
	break;
    }
    return;
1095
1096
1097
1098
1099
1100
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
int
Tcl_GlobObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, globFlags, join, dir, result;

    const char *separators;
    Tcl_Obj *typePtr;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static const char *const options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails",
	"-types", "--", NULL
    };
    enum globOptionsEnum {
	GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
	GLOB_TYPE, GLOB_LAST
    } index;
    enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};

    globFlags = 0;
    join = 0;
    dir = PATH_NONE;
    typePtr = NULL;
    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options,
		"option", 0, &index) != TCL_OK) {
	    const char *string = TclGetString(objv[i]);
	    if (string[0] == '-') {







|
>















|







1095
1096
1097
1098
1099
1100
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
int
Tcl_GlobObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int i, globFlags, dir, result;
    bool join;
    const char *separators;
    Tcl_Obj *typePtr;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static const char *const options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails",
	"-types", "--", NULL
    };
    enum globOptionsEnum {
	GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
	GLOB_TYPE, GLOB_LAST
    } index;
    enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};

    globFlags = 0;
    join = false;
    dir = PATH_NONE;
    typePtr = NULL;
    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options,
		"option", 0, &index) != TCL_OK) {
	    const char *string = TclGetString(objv[i]);
	    if (string[0] == '-') {
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
	    }
	    dir = PATH_DIR;
	    globFlags |= TCL_GLOBMODE_DIR;
	    pathOrDir = objv[i + 1];
	    i++;
	    break;
	case GLOB_JOIN:				/* -join */
	    join = 1;
	    break;
	case GLOB_TAILS:				/* -tails */
	    globFlags |= TCL_GLOBMODE_TAILS;
	    break;
	case GLOB_PATH:				/* -path */
	    if (i == objc - 1) {
		TclPrintfResult(interp, "missing argument to \"-path\"");







|







1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
	    }
	    dir = PATH_DIR;
	    globFlags |= TCL_GLOBMODE_DIR;
	    pathOrDir = objv[i + 1];
	    i++;
	    break;
	case GLOB_JOIN:				/* -join */
	    join = true;
	    break;
	case GLOB_TAILS:				/* -tails */
	    globFlags |= TCL_GLOBMODE_TAILS;
	    break;
	case GLOB_PATH:				/* -path */
	    if (i == objc - 1) {
		TclPrintfResult(interp, "missing argument to \"-path\"");
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
		 */

	    badTypesArg:
		TclPrintfResult(interp, "bad argument to \"-types\": %s",
			TclGetString(look));
		TclSetErrorCode(interp, "TCL", "ARGUMENT", "BAD");
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;

	    badMacTypesArg:
		TclPrintfResult(interp,
			"only one MacOS type or creator argument"
			" to \"-types\" allowed");
		result = TCL_ERROR;
		TclSetErrorCode(interp, "TCL", "ARGUMENT", "BAD");
		join = 0;
		goto endOfGlob;
	    }
	}
    }

  skipTypes:
    /*







|








|







1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
		 */

	    badTypesArg:
		TclPrintfResult(interp, "bad argument to \"-types\": %s",
			TclGetString(look));
		TclSetErrorCode(interp, "TCL", "ARGUMENT", "BAD");
		result = TCL_ERROR;
		join = false;
		goto endOfGlob;

	    badMacTypesArg:
		TclPrintfResult(interp,
			"only one MacOS type or creator argument"
			" to \"-types\" allowed");
		result = TCL_ERROR;
		TclSetErrorCode(interp, "TCL", "ARGUMENT", "BAD");
		join = false;
		goto endOfGlob;
	    }
	}
    }

  skipTypes:
    /*
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879

1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
 * SkipToChar --
 *
 *	This function traverses a glob pattern looking for the next unquoted
 *	occurrence of the specified character at the same braces nesting level.
 *
 * Results:
 *	Updates stringPtr to point to the matching character, or to the end of
 *	the string if nothing matched. The return value is 1 if a match was
 *	found at the top level, otherwise it is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SkipToChar(
    char **stringPtr,		/* Pointer string to check. */
    int match)			/* Character to find. */
{
    int quoted, level;
    char *p;

    quoted = 0;
    level = 0;


    for (p = *stringPtr; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;
	    continue;
	}
	if ((level == 0) && (*p == match)) {
	    *stringPtr = p;
	    return 1;
	}
	if (*p == '{') {
	    level++;
	} else if (*p == '}') {
	    level--;
	} else if (*p == '\\') {
	    quoted = 1;
	}
    }
    *stringPtr = p;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * DoGlob --
 *







|
|







|




<
<
<
|
|
>



|




|






|



|







1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875



1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
 * SkipToChar --
 *
 *	This function traverses a glob pattern looking for the next unquoted
 *	occurrence of the specified character at the same braces nesting level.
 *
 * Results:
 *	Updates stringPtr to point to the matching character, or to the end of
 *	the string if nothing matched. The return value is true if a match was
 *	found at the top level, otherwise it is false.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
SkipToChar(
    char **stringPtr,		/* Pointer string to check. */
    int match)			/* Character to find. */
{



    bool quoted = false;
    int level = 0;
    char *p;

    for (p = *stringPtr; *p != '\0'; p++) {
	if (quoted) {
	    quoted = false;
	    continue;
	}
	if ((level == 0) && (*p == match)) {
	    *stringPtr = p;
	    return true;
	}
	if (*p == '{') {
	    level++;
	} else if (*p == '}') {
	    level--;
	} else if (*p == '\\') {
	    quoted = true;
	}
    }
    *stringPtr = p;
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * DoGlob --
 *
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
    int flags,			/* If non-zero then pathPtr is a directory */
    char *pattern,		/* The pattern to match against. Must not be a
				 * pointer to a static string. */
    Tcl_GlobTypeData *types)	/* List object containing list of acceptable
				 * types. May be NULL. */
{
    Tcl_Size baseLength;
    int quoted, result = TCL_OK;
    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
    Tcl_Obj *joinedPtr;

    /*
     * Consume any leading directory separators, leaving pattern pointing just
     * past the last initial separator.
     */







|







1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
    int flags,			/* If non-zero then pathPtr is a directory */
    char *pattern,		/* The pattern to match against. Must not be a
				 * pointer to a static string. */
    Tcl_GlobTypeData *types)	/* List object containing list of acceptable
				 * types. May be NULL. */
{
    Tcl_Size baseLength;
    int result = TCL_OK;
    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
    Tcl_Obj *joinedPtr;

    /*
     * Consume any leading directory separators, leaving pattern pointing just
     * past the last initial separator.
     */
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997

    /*
     * Look for the first matching pair of braces or the first directory
     * separator that is not inside a pair of braces.
     */

    openBrace = closeBrace = NULL;
    quoted = 0;
    for (p = pattern; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;

	} else if (*p == '\\') {
	    quoted = 1;
	    if (strchr(separators, p[1]) != NULL) {
		/*
		 * Quoted directory separator.
		 */
		break;
	    }








|


|


|







1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996

    /*
     * Look for the first matching pair of braces or the first directory
     * separator that is not inside a pair of braces.
     */

    openBrace = closeBrace = NULL;
    bool quoted = false;
    for (p = pattern; *p != '\0'; p++) {
	if (quoted) {
	    quoted = false;

	} else if (*p == '\\') {
	    quoted = true;
	    if (strchr(separators, p[1]) != NULL) {
		/*
		 * Quoted directory separator.
		 */
		break;
	    }

Changes to generic/tclFileSystem.h.
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
/*
 * The internal TclFS API provides routines for handling and manipulating
 * paths efficiently, taking direct advantage of the "path" Tcl_Obj type.
 *
 * These functions are not exported at all at present.
 */

MODULE_SCOPE int	TclFSCwdPointerEquals(Tcl_Obj **pathPtrPtr);
MODULE_SCOPE int	TclFSNormalizeToUniquePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int startAt);
MODULE_SCOPE Tcl_Obj *	TclFSMakePathRelative(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr);
MODULE_SCOPE int	TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void	TclFSSetPathDetails(Tcl_Obj *pathPtr,







|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
/*
 * The internal TclFS API provides routines for handling and manipulating
 * paths efficiently, taking direct advantage of the "path" Tcl_Obj type.
 *
 * These functions are not exported at all at present.
 */

MODULE_SCOPE bool	TclFSCwdPointerEquals(Tcl_Obj **pathPtrPtr);
MODULE_SCOPE int	TclFSNormalizeToUniquePath(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int startAt);
MODULE_SCOPE Tcl_Obj *	TclFSMakePathRelative(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr);
MODULE_SCOPE int	TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void	TclFSSetPathDetails(Tcl_Obj *pathPtr,
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr,
			    Tcl_Size pathLen, const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int	TclFSEpochOk(size_t filesystemEpoch);
MODULE_SCOPE int	TclFSCwdIsNative(void);
MODULE_SCOPE Tcl_Obj *	TclWinVolumeRelativeNormalize(Tcl_Interp *interp,
			    const char *path, Tcl_Obj **useThisCwdPtr);

MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep;

#endif /* _TCLFILESYSTEM */







|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr,
			    Tcl_Size pathLen, const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr,
			    const Tcl_Filesystem **filesystemPtrPtr,
			    Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef);
MODULE_SCOPE int	TclFSEpochOk(size_t filesystemEpoch);
MODULE_SCOPE bool	TclFSCwdIsNative(void);
MODULE_SCOPE Tcl_Obj *	TclWinVolumeRelativeNormalize(Tcl_Interp *interp,
			    const char *path, Tcl_Obj **useThisCwdPtr);

MODULE_SCOPE Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
MODULE_SCOPE Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep;

#endif /* _TCLFILESYSTEM */
Changes to generic/tclHash.c.
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
Tcl_CreateHashEntry(
    Tcl_HashTable *tablePtr,	/* Table in which to lookup entry. */
    const void *key,		/* Key to use to find or create matching
				 * entry. */
    int *newPtr)		/* Store info here telling whether a new entry
				 * was created. */
{
    Tcl_HashEntry *entry = (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
    if (!entry) {
	Tcl_Panic("%s: Memory overflow", "Tcl_CreateHashEntry");
    }
    return entry;
}

Tcl_HashEntry *
Tcl_DbCreateHashEntry(
    Tcl_HashTable *tablePtr,	/* Table in which to lookup entry. */
    const void *key,		/* Key to use to find or create matching
				 * entry. */
    int *newPtr,		/* Store info here telling whether a new entry
				 * was created. */
    const char *file,
    int line)
{
    Tcl_HashEntry *entry = (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
    if (!entry) {
	Tcl_Panic("%s: Memory overflow in file %s:%d", "Tcl_CreateHashEntry", file, line);
    }
    return entry;
}

static Tcl_HashEntry *







|
















|







247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
Tcl_CreateHashEntry(
    Tcl_HashTable *tablePtr,	/* Table in which to lookup entry. */
    const void *key,		/* Key to use to find or create matching
				 * entry. */
    int *newPtr)		/* Store info here telling whether a new entry
				 * was created. */
{
    Tcl_HashEntry *entry = tablePtr->createProc(tablePtr, (const char *)key, newPtr);
    if (!entry) {
	Tcl_Panic("%s: Memory overflow", "Tcl_CreateHashEntry");
    }
    return entry;
}

Tcl_HashEntry *
Tcl_DbCreateHashEntry(
    Tcl_HashTable *tablePtr,	/* Table in which to lookup entry. */
    const void *key,		/* Key to use to find or create matching
				 * entry. */
    int *newPtr,		/* Store info here telling whether a new entry
				 * was created. */
    const char *file,
    int line)
{
    Tcl_HashEntry *entry = tablePtr->createProc(tablePtr, (const char *)key, newPtr);
    if (!entry) {
	Tcl_Panic("%s: Memory overflow in file %s:%d", "Tcl_CreateHashEntry", file, line);
    }
    return entry;
}

static Tcl_HashEntry *
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
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
		if (hash != hPtr->hash) {
		    continue;
		}
		/* if keys pointers or values are equal */
		if ((key == hPtr->key.oneWordValue)
		    || compareKeysProc((void *) key, hPtr)) {
		    if (newPtr && (newPtr != TCL_HASH_FIND)) {
			*newPtr = 0;
		    }
		    return hPtr;
		}
	    }
	} else { /* no direct compare - compare key addresses only */
	    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		    hPtr = hPtr->nextPtr) {
		if (hash != hPtr->hash) {
		    continue;
		}
		/* if needle pointer equals content pointer or values equal */
		if ((key == hPtr->key.string)
			|| compareKeysProc((void *) key, hPtr)) {
		    if (newPtr && (newPtr != TCL_HASH_FIND)) {
			*newPtr = 0;
		    }
		    return hPtr;
		}
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
	    if (hash != hPtr->hash) {
		continue;
	    }
	    if (key == hPtr->key.oneWordValue) {
		if (newPtr && (newPtr != TCL_HASH_FIND)) {
		    *newPtr = 0;
		}
		return hPtr;
	    }
	}
    }

    if (newPtr == TCL_HASH_FIND) {
	/* This is the findProc functionality, so we are done. */
	return NULL;
    }

    /*
     * Entry not found. Add a new one to the bucket.
     */

    if (newPtr) {
	*newPtr = 1;
    }
    if (typePtr->allocEntryProc) {
	hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
    } else {
	hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(sizeof(Tcl_HashEntry));
	if (!hPtr) {
	    return NULL;







|














|













|
















|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
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
		if (hash != hPtr->hash) {
		    continue;
		}
		/* if keys pointers or values are equal */
		if ((key == hPtr->key.oneWordValue)
		    || compareKeysProc((void *) key, hPtr)) {
		    if (newPtr && (newPtr != TCL_HASH_FIND)) {
			*newPtr = false;
		    }
		    return hPtr;
		}
	    }
	} else { /* no direct compare - compare key addresses only */
	    for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		    hPtr = hPtr->nextPtr) {
		if (hash != hPtr->hash) {
		    continue;
		}
		/* if needle pointer equals content pointer or values equal */
		if ((key == hPtr->key.string)
			|| compareKeysProc((void *) key, hPtr)) {
		    if (newPtr && (newPtr != TCL_HASH_FIND)) {
			*newPtr = false;
		    }
		    return hPtr;
		}
	    }
	}
    } else {
	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
		hPtr = hPtr->nextPtr) {
	    if (hash != hPtr->hash) {
		continue;
	    }
	    if (key == hPtr->key.oneWordValue) {
		if (newPtr && (newPtr != TCL_HASH_FIND)) {
		    *newPtr = false;
		}
		return hPtr;
	    }
	}
    }

    if (newPtr == TCL_HASH_FIND) {
	/* This is the findProc functionality, so we are done. */
	return NULL;
    }

    /*
     * Entry not found. Add a new one to the bucket.
     */

    if (newPtr) {
	*newPtr = true;
    }
    if (typePtr->allocEntryProc) {
	hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
    } else {
	hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(sizeof(Tcl_HashEntry));
	if (!hPtr) {
	    return NULL;
Changes to generic/tclHistory.c.
116
117
118
119
120
121
122
123

124
125
126
127
128
129
130
				 * record and execute. */
    int flags)			/* Additional flags. TCL_NO_EVAL means record
				 * only: don't execute the command.
				 * TCL_EVAL_GLOBAL means evaluate the script
				 * in global variable context instead of the
				 * current procedure. */
{
    int result, call = 1;

    Tcl_CmdInfo info;
    HistoryObjs *histObjsPtr =
	    (HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);

    /*
     * Create the references to the [::history add] command if necessary.
     */







|
>







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
				 * record and execute. */
    int flags)			/* Additional flags. TCL_NO_EVAL means record
				 * only: don't execute the command.
				 * TCL_EVAL_GLOBAL means evaluate the script
				 * in global variable context instead of the
				 * current procedure. */
{
    int result;
    bool call = true;
    Tcl_CmdInfo info;
    HistoryObjs *histObjsPtr =
	    (HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);

    /*
     * Create the references to the [::history add] command if necessary.
     */
Changes to generic/tclIO.c.
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
				 * indexed by ChannelState, as only one
				 * ChannelState exists per set of stacked
				 * channels. */
    Tcl_Channel stdinChannel;	/* Static variable for the stdin channel. */
    Tcl_Channel stdoutChannel;	/* Static variable for the stdout channel. */
    Tcl_Channel stderrChannel;	/* Static variable for the stderr channel. */
    Tcl_Encoding binaryEncoding;
    int stdinInitialized;
    int stdoutInitialized;
    int stderrInitialized;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Key for looking up the channel table (a Tcl_HashTable indexed by channel
 * name) in the interpreter's associated data table.







|
|
|







126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
				 * indexed by ChannelState, as only one
				 * ChannelState exists per set of stacked
				 * channels. */
    Tcl_Channel stdinChannel;	/* Static variable for the stdin channel. */
    Tcl_Channel stdoutChannel;	/* Static variable for the stdout channel. */
    Tcl_Channel stderrChannel;	/* Static variable for the stderr channel. */
    Tcl_Encoding binaryEncoding;
    int stdinInitialized;	/* 0, 1 or -1 (error in init) */
    int stdoutInitialized;	/* 0, 1 or -1 (error in init) */
    int stderrInitialized;	/* 0, 1 or -1 (error in init) */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Key for looking up the channel table (a Tcl_HashTable indexed by channel
 * name) in the interpreter's associated data table.
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
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
static void		ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int		IsShared(ChannelBuffer *bufPtr);
static void		ChannelFree(Channel *chanPtr);
static void		ChannelTimerProc(void *clientData);
static int		ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
			    Channel *chanPtr);
static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode);
static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode, int flags);
static int		CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void		CommonGetsCleanup(Channel *chanPtr);
static int		CopyData(CopyState *csPtr, int mask);
static void		DeleteTimerHandler(ChannelState *statePtr);
static int		Lossless(ChannelState *inStatePtr,
			    ChannelState *outStatePtr, long long toRead);
static int		MoveBytes(CopyState *csPtr);

static void		MBCallback(CopyState *csPtr, Tcl_Obj *errObj);
static void		MBError(CopyState *csPtr, int mask, int errorCode);
static int		MBRead(CopyState *csPtr);
static int		MBWrite(CopyState *csPtr);
static void		MBEvent(void *clientData, int mask);

static void		CopyEventProc(void *clientData, int mask);
static void		CreateScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
static void		DeleteChannelTable(void *clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask);
static int		DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
static void		DiscardInputQueued(ChannelState *statePtr,
			    int discardSavedBuffers);
static void		DiscardOutputQueued(ChannelState *chanPtr);
static Tcl_Size		DoRead(Channel *chanPtr, char *dst, Tcl_Size bytesToRead,
			    int allowShortReads);
static Tcl_Size		DoReadChars(Channel *chan, Tcl_Obj *objPtr, Tcl_Size toRead,
			    int allowShortReads, int appendFlag);
static int		FilterInputBytes(Channel *chanPtr,
			    GetsState *statePtr);
static int		FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int calledFromAsyncFlush);
static int		TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static Tcl_Encoding	GetBinaryEncoding(void);
static void		FreeBinaryEncoding(void);
static Tcl_HashTable *	GetChannelTable(Tcl_Interp *interp);
static int		GetInput(Channel *chanPtr);
static void		PeekAhead(Channel *chanPtr, char **dstEndPtr,
			    GetsState *gsPtr);
static int		ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft);
static int		ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft, int *factorPtr);
static void		RecycleBuffer(ChannelState *statePtr,
			    ChannelBuffer *bufPtr, int mustDiscard);
static int		StackSetBlockMode(Channel *chanPtr, int mode);
static int		SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
			    int mode);
static void		StopCopy(CopyState *csPtr);
static void		CopyDecrRefCount(CopyState *csPtr);
static void		TranslateInputEOL(ChannelState *statePtr, char *dst,
			    const char *src, int *dstLenPtr, int *srcLenPtr);
static void		UpdateInterest(Channel *chanPtr);
static Tcl_Size		Write(Channel *chanPtr, const char *src,
			    Tcl_Size srcLen, Tcl_Encoding encoding);
static Tcl_Obj *	FixLevelCode(Tcl_Obj *msg);
static void		SpliceChannel(Tcl_Channel chan);
static void		CutChannel(Tcl_Channel chan);
static int	      WillRead(Channel *chanPtr);

#define WriteChars(chanPtr, src, srcLen) \
			Write(chanPtr, src, srcLen, chanPtr->state->encoding)
#define WriteBytes(chanPtr, src, srcLen) \
			Write(chanPtr, src, srcLen, tclIdentityEncoding)

/*
 * Simplifying helper macros. All may use their argument(s) multiple times.
 * The ANSI C "prototypes" for the macros are listed below, together with a
 * short description of what the macro does.
 *
 * --------------------------------------------------------------------------







|












|


















|


|

|



|












|
















|

|







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
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
static void		ReleaseChannelBuffer(ChannelBuffer *bufPtr);
static int		IsShared(ChannelBuffer *bufPtr);
static void		ChannelFree(Channel *chanPtr);
static void		ChannelTimerProc(void *clientData);
static int		ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static bool		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
			    Channel *chanPtr);
static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode);
static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode, int flags);
static int		CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void		CommonGetsCleanup(Channel *chanPtr);
static int		CopyData(CopyState *csPtr, int mask);
static void		DeleteTimerHandler(ChannelState *statePtr);
static bool		Lossless(ChannelState *inStatePtr,
			    ChannelState *outStatePtr, long long toRead);
static int		MoveBytes(CopyState *csPtr);

static void		MBCallback(CopyState *csPtr, Tcl_Obj *errObj);
static void		MBError(CopyState *csPtr, int mask, int errorCode);
static int		MBRead(CopyState *csPtr);
static int		MBWrite(CopyState *csPtr);
static void		MBEvent(void *clientData, int mask);

static void		CopyEventProc(void *clientData, int mask);
static void		CreateScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
static void		DeleteChannelTable(void *clientData,
			    Tcl_Interp *interp);
static void		DeleteScriptRecord(Tcl_Interp *interp,
			    Channel *chanPtr, int mask);
static int		DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
static void		DiscardInputQueued(ChannelState *statePtr,
			    bool discardSavedBuffers);
static void		DiscardOutputQueued(ChannelState *chanPtr);
static Tcl_Size		DoRead(Channel *chanPtr, char *dst, Tcl_Size bytesToRead,
			    bool allowShortReads);
static Tcl_Size		DoReadChars(Channel *chan, Tcl_Obj *objPtr, Tcl_Size toRead,
			    bool allowShortReads, bool appendFlag);
static int		FilterInputBytes(Channel *chanPtr,
			    GetsState *statePtr);
static int		FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
			    bool calledFromAsyncFlush);
static int		TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static Tcl_Encoding	GetBinaryEncoding(void);
static void		FreeBinaryEncoding(void);
static Tcl_HashTable *	GetChannelTable(Tcl_Interp *interp);
static int		GetInput(Channel *chanPtr);
static void		PeekAhead(Channel *chanPtr, char **dstEndPtr,
			    GetsState *gsPtr);
static int		ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft);
static int		ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr,
			    int charsLeft, int *factorPtr);
static void		RecycleBuffer(ChannelState *statePtr,
			    ChannelBuffer *bufPtr, bool mustDiscard);
static int		StackSetBlockMode(Channel *chanPtr, int mode);
static int		SetBlockMode(Tcl_Interp *interp, Channel *chanPtr,
			    int mode);
static void		StopCopy(CopyState *csPtr);
static void		CopyDecrRefCount(CopyState *csPtr);
static void		TranslateInputEOL(ChannelState *statePtr, char *dst,
			    const char *src, int *dstLenPtr, int *srcLenPtr);
static void		UpdateInterest(Channel *chanPtr);
static Tcl_Size		Write(Channel *chanPtr, const char *src,
			    Tcl_Size srcLen, Tcl_Encoding encoding);
static Tcl_Obj *	FixLevelCode(Tcl_Obj *msg);
static void		SpliceChannel(Tcl_Channel chan);
static void		CutChannel(Tcl_Channel chan);
static int	      WillRead(Channel *chanPtr);

#define WriteChars(chanPtr, src, srcLen) \
	Write(chanPtr, src, srcLen, chanPtr->state->encoding)
#define WriteBytes(chanPtr, src, srcLen) \
	Write(chanPtr, src, srcLen, tclIdentityEncoding)

/*
 * Simplifying helper macros. All may use their argument(s) multiple times.
 * The ANSI C "prototypes" for the macros are listed below, together with a
 * short description of what the macro does.
 *
 * --------------------------------------------------------------------------
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

void
TclFinalizeIOSubsystem(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr = NULL;	/* Iterates over open channels. */
    ChannelState *statePtr;	/* State of channel stack */
    int active = 1;		/* Flag == 1 while there's still work to do */
    int doflushnb;

    /*
     * Fetch the pre-TIP#398 compatibility flag.
     */

    {







|







580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

void
TclFinalizeIOSubsystem(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Channel *chanPtr = NULL;	/* Iterates over open channels. */
    ChannelState *statePtr;	/* State of channel stack */
    bool active = true;		/* Flag set while there's still work to do */
    int doflushnb;

    /*
     * Fetch the pre-TIP#398 compatibility flag.
     */

    {
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    while (active) {
	/*
	 * Iterate through the open channel list, and find the first channel
	 * that isn't dead. We start from the head of the list each time,
	 * because the close action on one channel can close others.
	 */

	active = 0;
	for (statePtr = tsdPtr->firstCSPtr;
		statePtr != NULL;
		statePtr = statePtr->nextCSPtr) {
	    chanPtr = statePtr->topChanPtr;
	    if (GotFlag(statePtr, CHANNEL_DEAD)) {
		continue;
	    }
	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
		    || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
		ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
		active = 1;
		break;
	    }
	}

	/*
	 * We've found a live (or bg-closing) channel. Close it.
	 */







|










|







610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    while (active) {
	/*
	 * Iterate through the open channel list, and find the first channel
	 * that isn't dead. We start from the head of the list each time,
	 * because the close action on one channel can close others.
	 */

	active = false;
	for (statePtr = tsdPtr->firstCSPtr;
		statePtr != NULL;
		statePtr = statePtr->nextCSPtr) {
	    chanPtr = statePtr->topChanPtr;
	    if (GotFlag(statePtr, CHANNEL_DEAD)) {
		continue;
	    }
	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED )
		    || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
		ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
		active = true;
		break;
	    }
	}

	/*
	 * We've found a live (or bg-closing) channel. Close it.
	 */
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
1151
1152
1153
1154
1155
 * Tcl_IsStandardChannel --
 *
 *	Test if the given channel is a standard channel. No attempt is made to
 *	check if the channel or the standard channels are initialized or
 *	otherwise valid.
 *
 * Results:
 *	Returns 1 if true, 0 if false.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsStandardChannel(
    Tcl_Channel chan)		/* Channel to check. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if ((chan == tsdPtr->stdinChannel)
	    || (chan == tsdPtr->stdoutChannel)
	    || (chan == tsdPtr->stderrChannel)) {
	return 1;
    } else {
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterChannel --







|
















|

|







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
1151
1152
1153
1154
1155
 * Tcl_IsStandardChannel --
 *
 *	Test if the given channel is a standard channel. No attempt is made to
 *	check if the channel or the standard channels are initialized or
 *	otherwise valid.
 *
 * Results:
 *	Returns true or false.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsStandardChannel(
    Tcl_Channel chan)		/* Channel to check. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if ((chan == tsdPtr->stdinChannel)
	    || (chan == tsdPtr->stdoutChannel)
	    || (chan == tsdPtr->stderrChannel)) {
	return true;
    } else {
	return false;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegisterChannel --
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
		statePtr->inQueueHead = chanPtr->inQueueHead;
		statePtr->inQueueTail = chanPtr->inQueueTail;
	    }

	    chanPtr->inQueueHead = NULL;
	    chanPtr->inQueueTail = NULL;

	    DiscardInputQueued(statePtr, 0);
	}

	/*
	 * TIP #218, Channel Thread Actions.
	 *
	 * We call the thread actions for the new channel directly. We
	 * _cannot_ use CutChannel, because the (thread-)global list of all







|







2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
		statePtr->inQueueHead = chanPtr->inQueueHead;
		statePtr->inQueueTail = chanPtr->inQueueTail;
	    }

	    chanPtr->inQueueHead = NULL;
	    chanPtr->inQueueTail = NULL;

	    DiscardInputQueued(statePtr, false);
	}

	/*
	 * TIP #218, Channel Thread Actions.
	 *
	 * We call the thread actions for the new channel directly. We
	 * _cannot_ use CutChannel, because the (thread-)global list of all
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of actual channel. */

    if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
	emsg = "Illegal mode value.";
	goto error;
    }
    if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) {
	emsg = "Bad mode, would make channel inacessible";
	goto error;
    }

    ResetFlag(statePtr, mode);
    return TCL_OK;








|







2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of actual channel. */

    if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
	emsg = "Illegal mode value.";
	goto error;
    }
    if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) {
	emsg = "Bad mode, would make channel inacessible";
	goto error;
    }

    ResetFlag(statePtr, mode);
    return TCL_OK;

2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
 *----------------------------------------------------------------------
 */

static void
RecycleBuffer(
    ChannelState *statePtr,	/* ChannelState in which to recycle buffers. */
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    int mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */

    if (IsShared(bufPtr)) {
	mustDiscard = 1;
    }

    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }








|







|







2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
 *----------------------------------------------------------------------
 */

static void
RecycleBuffer(
    ChannelState *statePtr,	/* ChannelState in which to recycle buffers. */
    ChannelBuffer *bufPtr,	/* The buffer to recycle. */
    bool mustDiscard)		/* If nonzero, free the buffer to the OS,
				 * always. */
{
    /*
     * Do we have to free the buffer to the OS?
     */

    if (IsShared(bufPtr)) {
	mustDiscard = true;
    }

    if (mustDiscard) {
	ReleaseChannelBuffer(bufPtr);
	return;
    }

2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
 *
 * CheckForDeadChannel --
 *
 *	This function checks is a given channel is Dead (a channel that has
 *	been closed but not yet deallocated.)
 *
 * Results:
 *	True (1) if channel is Dead, False (0) if channel is Ok
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static int
CheckForDeadChannel(
    Tcl_Interp *interp,		/* For error reporting (can be NULL) */
    ChannelState *statePtr)	/* The channel state to check. */
{
    if (!GotFlag(statePtr, CHANNEL_DEAD)) {
	return 0;
    }

    Tcl_SetErrno(EINVAL);
    if (interp) {
	TclPrintfResult(interp, "unable to access channel: invalid channel");
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * FlushChannel --
 *







|







|





|






|







2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
 *
 * CheckForDeadChannel --
 *
 *	This function checks is a given channel is Dead (a channel that has
 *	been closed but not yet deallocated.)
 *
 * Results:
 *	True if channel is Dead, False if channel is Ok
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static bool
CheckForDeadChannel(
    Tcl_Interp *interp,		/* For error reporting (can be NULL) */
    ChannelState *statePtr)	/* The channel state to check. */
{
    if (!GotFlag(statePtr, CHANNEL_DEAD)) {
	return false;
    }

    Tcl_SetErrno(EINVAL);
    if (interp) {
	TclPrintfResult(interp, "unable to access channel: invalid channel");
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * FlushChannel --
 *
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
 *----------------------------------------------------------------------
 */

static int
FlushChannel(
    Tcl_Interp *interp,		/* For error reporting during close. */
    Channel *chanPtr,		/* The channel to flush on. */
    int calledFromAsyncFlush)	/* If nonzero then we are being called from an
				 * asynchronous flush callback. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State of the channel stack. */
    ChannelBuffer *bufPtr;	/* Iterates over buffered output queue. */
    int written;		/* Amount of output data actually written in
				 * current round. */
    int errorCode = 0;		/* Stores POSIX error codes from channel
				 * driver operations. */
    int wroteSome = 0;		/* Set to one if any data was written to the
				 * driver. */

    int bufExists;
    /*
     * Prevent writing on a dead channel -- a channel that has been closed but
     * not yet deallocated. This can occur if the exit handler for the channel
     * deallocation runs before all channels are unregistered in all







|









|







2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
 *----------------------------------------------------------------------
 */

static int
FlushChannel(
    Tcl_Interp *interp,		/* For error reporting during close. */
    Channel *chanPtr,		/* The channel to flush on. */
    bool calledFromAsyncFlush)	/* If true then we are being called from an
				 * asynchronous flush callback. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State of the channel stack. */
    ChannelBuffer *bufPtr;	/* Iterates over buffered output queue. */
    int written;		/* Amount of output data actually written in
				 * current round. */
    int errorCode = 0;		/* Stores POSIX error codes from channel
				 * driver operations. */
    bool wroteSome = false;	/* Whether any data was written to the
				 * driver. */

    int bufExists;
    /*
     * Prevent writing on a dead channel -- a channel that has been closed but
     * not yet deallocated. This can occur if the exit handler for the channel
     * deallocation runs before all channels are unregistered in all
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
	    break;
	} else {
	    /*
	     * TODO: Consider detecting and reacting to short writes on
	     * blocking channels.  Ought not happen.  See iocmd-24.2.
	     */

	    wroteSome = 1;
	}

	bufExists = bufPtr->refCount > 1;
	ReleaseChannelBuffer(bufPtr);
	if (bufExists) {
	    /* There is still a reference to this buffer other than the one
	     * this routine just released, meaning that final cleanup of the







|







2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
	    break;
	} else {
	    /*
	     * TODO: Consider detecting and reacting to short writes on
	     * blocking channels.  Ought not happen.  See iocmd-24.2.
	     */

	    wroteSome = true;
	}

	bufExists = bufPtr->refCount > 1;
	ReleaseChannelBuffer(bufPtr);
	if (bufExists) {
	    /* There is still a reference to this buffer other than the one
	     * this routine just released, meaning that final cleanup of the
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
    ChannelState *statePtr = (ChannelState *)blockPtr;
    /*
     * Even after close some members can be filled again (in events etc).
     * Test in bug [79474c588] illustrates one leak (on remaining chanMsg).
     * Possible other fields need freeing on some constellations.
     */

    DiscardInputQueued(statePtr, 1);
    if (statePtr->curOutPtr != NULL) {
	ReleaseChannelBuffer(statePtr->curOutPtr);
    }
    DiscardOutputQueued(statePtr);

    DeleteTimerHandler(statePtr);








|







3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
    ChannelState *statePtr = (ChannelState *)blockPtr;
    /*
     * Even after close some members can be filled again (in events etc).
     * Test in bug [79474c588] illustrates one leak (on remaining chanMsg).
     * Possible other fields need freeing on some constellations.
     */

    DiscardInputQueued(statePtr, true);
    if (statePtr->curOutPtr != NULL) {
	ReleaseChannelBuffer(statePtr->curOutPtr);
    }
    DiscardOutputQueued(statePtr);

    DeleteTimerHandler(statePtr);

3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
    }
    statePtr = chanPtr->state;

    /*
     * No more input can be consumed so discard any leftover input.
     */

    DiscardInputQueued(statePtr, 1);

    /*
     * Discard a leftover buffer in the current output buffer field.
     */

    if (statePtr->curOutPtr != NULL) {
	ReleaseChannelBuffer(statePtr->curOutPtr);







|







3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
    }
    statePtr = chanPtr->state;

    /*
     * No more input can be consumed so discard any leftover input.
     */

    DiscardInputQueued(statePtr, true);

    /*
     * Discard a leftover buffer in the current output buffer field.
     */

    if (statePtr->curOutPtr != NULL) {
	ReleaseChannelBuffer(statePtr->curOutPtr);
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSED);

    int flushcode = FlushChannel(interp, chanPtr, 0);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSED in the flags







|







3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSED);

    int flushcode = FlushChannel(interp, chanPtr, false);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSED in the flags
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);

    int flushcode = FlushChannel(interp, chanPtr, 0);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags







|







3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
     * The call to FlushChannel will flush any queued output and invoke the
     * close function of the channel driver, or it will set up the channel to
     * be flushed and closed asynchronously.
     */

    SetFlag(statePtr, CHANNEL_CLOSEDWRITE);

    int flushcode = FlushChannel(interp, chanPtr, false);

    /*
     * TIP #219.
     * Capture error messages put by the driver into the bypass area and put
     * them into the regular interpreter result.
     *
     * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
    statePtr = chanPtr->state;

    if (flags & TCL_CLOSE_READ) {
	/*
	 * No more input can be consumed so discard any leftover input.
	 */

	DiscardInputQueued(statePtr, 1);
    } else if (flags & TCL_CLOSE_WRITE) {
	/*
	 * The caller guarantees that there are no more buffers queued for
	 * output.
	 */

	if (statePtr->outQueueHead != NULL) {







|







3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
    statePtr = chanPtr->state;

    if (flags & TCL_CLOSE_READ) {
	/*
	 * No more input can be consumed so discard any leftover input.
	 */

	DiscardInputQueued(statePtr, true);
    } else if (flags & TCL_CLOSE_WRITE) {
	/*
	 * The caller guarantees that there are no more buffers queued for
	 * output.
	 */

	if (statePtr->outQueueHead != NULL) {
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
{
    int inputBuffered;

    if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
	    && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
	int ignore;

	DiscardInputQueued(chanPtr->state, 0);
	ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore);
    }
}

static int
WillRead(
    Channel *chanPtr)
{
    if (chanPtr->typePtr == NULL) {
	/*
	 * Prevent read attempts on a closed channel.
	 */

	DiscardInputQueued(chanPtr->state, 0);
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
	    && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
	/*
	 * CAVEAT - The assumption here is that FlushChannel() will push out
	 * the bytes of any writes that are in progress.  Since this is a
	 * seekable channel, we assume it is not one that can block and force
	 * bg flushing.  Channels we know that can do that - sockets, pipes -
	 * are not seekable. If the assumption is wrong, more drastic measures
	 * may be required here like temporarily setting the channel into
	 * blocking mode.
	 */

	if (FlushChannel(NULL, chanPtr, 0) != 0) {
	    return -1;
	}
    }
    return 0;
}

/*







|













|















|







4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
{
    int inputBuffered;

    if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
	    && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
	int ignore;

	DiscardInputQueued(chanPtr->state, false);
	ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore);
    }
}

static int
WillRead(
    Channel *chanPtr)
{
    if (chanPtr->typePtr == NULL) {
	/*
	 * Prevent read attempts on a closed channel.
	 */

	DiscardInputQueued(chanPtr->state, false);
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
	    && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
	/*
	 * CAVEAT - The assumption here is that FlushChannel() will push out
	 * the bytes of any writes that are in progress.  Since this is a
	 * seekable channel, we assume it is not one that can block and force
	 * bg flushing.  Channels we know that can do that - sockets, pipes -
	 * are not seekable. If the assumption is wrong, more drastic measures
	 * may be required here like temporarily setting the channel into
	 * blocking mode.
	 */

	if (FlushChannel(NULL, chanPtr, false) != 0) {
	    return -1;
	}
    }
    return 0;
}

/*
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
    const char *src,		/* UTF-8 string to write. */
    Tcl_Size srcLen,		/* Length of UTF-8 string in bytes. */
    Tcl_Encoding encoding)
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    char *nextNewLine = NULL;
    int endEncoding, needNlFlush = 0;
    Tcl_Size saved = 0, total = 0, flushed = 0;
    char safe[BUFFER_PADDING];
    int encodingError = 0;

    if (srcLen) {
	WillWrite(chanPtr);
    }

    /*
     * Write the terminated escape sequence even if srcLen is 0.
     */

    endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
    if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
	    || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
	nextNewLine = (char *)memchr(src, '\n', srcLen);
    }

    while (srcLen + saved + endEncoding > 0 && !encodingError) {
	ChannelBuffer *bufPtr;
	char *dst;
	int result, srcRead, dstLen, dstWrote;
	Tcl_Size srcLimit = srcLen;

	if (nextNewLine) {
	    srcLimit = nextNewLine - src;







|


<















|







4350
4351
4352
4353
4354
4355
4356
4357
4358
4359

4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
    const char *src,		/* UTF-8 string to write. */
    Tcl_Size srcLen,		/* Length of UTF-8 string in bytes. */
    Tcl_Encoding encoding)
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    char *nextNewLine = NULL;
    bool encodingError = false, endEncoding, needNlFlush = false;
    Tcl_Size saved = 0, total = 0, flushed = 0;
    char safe[BUFFER_PADDING];


    if (srcLen) {
	WillWrite(chanPtr);
    }

    /*
     * Write the terminated escape sequence even if srcLen is 0.
     */

    endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
    if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
	    || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
	nextNewLine = (char *)memchr(src, '\n', srcLen);
    }

    while (srcLen + saved + ((int) endEncoding) > 0 && !encodingError) {
	ChannelBuffer *bufPtr;
	char *dst;
	int result, srcRead, dstLen, dstWrote;
	Tcl_Size srcLimit = srcLen;

	if (nextNewLine) {
	    srcLimit = nextNewLine - src;
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
	 */

	if ((result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) ||
		/*
		 * We're reading from invalid/incomplete UTF-8.
		 */
		((result != TCL_OK) && (srcRead + dstWrote == 0))) {
	    encodingError = 1;
	    result = TCL_OK;
	}

	bufPtr->nextAdded += dstWrote;
	src += srcRead;
	srcLen -= srcRead;
	total += dstWrote;







|







4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
	 */

	if ((result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) ||
		/*
		 * We're reading from invalid/incomplete UTF-8.
		 */
		((result != TCL_OK) && (srcRead + dstWrote == 0))) {
	    encodingError = true;
	    result = TCL_OK;
	}

	bufPtr->nextAdded += dstWrote;
	src += srcRead;
	srcLen -= srcRead;
	total += dstWrote;
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
	    bufPtr->nextAdded += dstWrote;
	    src++;
	    srcLen--;
	    total += dstWrote;
	    dst += dstWrote;
	    dstLen -= dstWrote;
	    nextNewLine = (char *)memchr(src, '\n', srcLen);
	    needNlFlush = 1;
	}

	if (IsBufferOverflowing(bufPtr)) {
	    /*
	     * When translating from UTF-8 to external encoding, we allowed
	     * the translation to produce a character that crossed the end of
	     * the output buffer, so that we would get a completely full
	     * buffer before flushing it. The extra bytes will be moved to the
	     * beginning of the next buffer.
	     */

	    saved = -SpaceLeft(bufPtr);
	    memcpy(safe, dst + dstLen, saved);
	    bufPtr->nextAdded = bufPtr->bufLength;
	}

	if ((srcLen + saved == 0) && (result == TCL_OK)) {
	    endEncoding = 0;
	}

	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, 0) != 0) {
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
	     * We just flushed.  So if we have needNlFlush set to record that
	     * we need to flush because there is a (translated) newline in the
	     * buffer, that's likely not true any more.  But there is a tricky
	     * exception.  If we have saved bytes that did not really get
	     * flushed and those bytes came from a translation of a newline as
	     * the last thing taken from the src array, then needNlFlush needs
	     * to remain set to flag that the next buffer still needs a
	     * newline flush.
	     */

	    if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
		needNlFlush = 0;
	    }
	}
    }
    if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
	    (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
	if (FlushChannel(NULL, chanPtr, 0) != 0) {
	    return -1;
	}
    }

    UpdateInterest(chanPtr);

    if (encodingError) {







|

















|



|
















|





|







4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
	    bufPtr->nextAdded += dstWrote;
	    src++;
	    srcLen--;
	    total += dstWrote;
	    dst += dstWrote;
	    dstLen -= dstWrote;
	    nextNewLine = (char *)memchr(src, '\n', srcLen);
	    needNlFlush = true;
	}

	if (IsBufferOverflowing(bufPtr)) {
	    /*
	     * When translating from UTF-8 to external encoding, we allowed
	     * the translation to produce a character that crossed the end of
	     * the output buffer, so that we would get a completely full
	     * buffer before flushing it. The extra bytes will be moved to the
	     * beginning of the next buffer.
	     */

	    saved = -SpaceLeft(bufPtr);
	    memcpy(safe, dst + dstLen, saved);
	    bufPtr->nextAdded = bufPtr->bufLength;
	}

	if ((srcLen + saved == 0) && (result == TCL_OK)) {
	    endEncoding = false;
	}

	if (IsBufferFull(bufPtr)) {
	    if (FlushChannel(NULL, chanPtr, false) != 0) {
		return -1;
	    }
	    flushed += statePtr->bufSize;

	    /*
	     * We just flushed.  So if we have needNlFlush set to record that
	     * we need to flush because there is a (translated) newline in the
	     * buffer, that's likely not true any more.  But there is a tricky
	     * exception.  If we have saved bytes that did not really get
	     * flushed and those bytes came from a translation of a newline as
	     * the last thing taken from the src array, then needNlFlush needs
	     * to remain set to flag that the next buffer still needs a
	     * newline flush.
	     */

	    if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
		needNlFlush = false;
	    }
	}
    }
    if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
	    (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
	if (FlushChannel(NULL, chanPtr, false) != 0) {
	    return -1;
	}
    }

    UpdateInterest(chanPtr);

    if (encodingError) {
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663

    bufPtr = statePtr->inQueueHead;
    for ( ; bufPtr != NULL; bufPtr = nextPtr) {
	nextPtr = bufPtr->nextPtr;
	if (IsBufferReady(bufPtr)) {
	    break;
	}
	RecycleBuffer(statePtr, bufPtr, 0);
    }
    statePtr->inQueueHead = bufPtr;
    if (bufPtr == NULL) {
	statePtr->inQueueTail = NULL;
    } else {
	/*
	 * If any multi-byte characters were split across channel buffer







|







5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662

    bufPtr = statePtr->inQueueHead;
    for ( ; bufPtr != NULL; bufPtr = nextPtr) {
	nextPtr = bufPtr->nextPtr;
	if (IsBufferReady(bufPtr)) {
	    break;
	}
	RecycleBuffer(statePtr, bufPtr, false);
    }
    statePtr->inQueueHead = bufPtr;
    if (bufPtr == NULL) {
	statePtr->inQueueTail = NULL;
    } else {
	/*
	 * If any multi-byte characters were split across channel buffer
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
	 */

	if (IsBufferEmpty(bufPtr)) {
	    chanPtr->inQueueHead = bufPtr->nextPtr;
	    if (chanPtr->inQueueHead == NULL) {
		chanPtr->inQueueTail = NULL;
	    }
	    RecycleBuffer(chanPtr->state, bufPtr, 0);
	}
    }

    /*
     * Go to the driver only if we got nothing from pushback.  Have to do it
     * this way to avoid EOF mistimings when we consider the ability that EOF
     * may not be a permanent condition in the driver, and in that case we







|







5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
	 */

	if (IsBufferEmpty(bufPtr)) {
	    chanPtr->inQueueHead = bufPtr->nextPtr;
	    if (chanPtr->inQueueHead == NULL) {
		chanPtr->inQueueTail = NULL;
	    }
	    RecycleBuffer(chanPtr->state, bufPtr, false);
	}
    }

    /*
     * Go to the driver only if we got nothing from pushback.  Have to do it
     * this way to avoid EOF mistimings when we consider the ability that EOF
     * may not be a permanent condition in the driver, and in that case we
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
 *	been seen, EOF is seen, or the channel would block. EOL and EOF
 *	translation is done. If reading binary data, the raw bytes are wrapped
 *	in a Tcl byte array object. Otherwise, the raw bytes are converted to
 *	UTF-8 using the channel's current encoding and stored in a Tcl string
 *	object.
 *
 * Results:
 *	The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */







|







5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
 *	been seen, EOF is seen, or the channel would block. EOL and EOF
 *	translation is done. If reading binary data, the raw bytes are wrapped
 *	in a Tcl byte array object. Otherwise, the raw bytes are converted to
 *	UTF-8 using the channel's current encoding and stored in a Tcl string
 *	object.
 *
 * Results:
 *	The number of characters read, or TCL_IO_FAILURE on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	/*
	 * Update the notifier state so we don't block while there is still
	 * data in the buffers.
	 */

	UpdateInterest(chanPtr);
	return TCL_INDEX_NONE;
    }

    return DoReadChars(chanPtr, objPtr, toRead, 0, appendFlag);
}
/*
 *---------------------------------------------------------------------------
 *
 * DoReadChars --
 *
 *	Reads from the channel until the requested number of characters have
 *	been seen, EOF is seen, or the channel would block. EOL and EOF
 *	translation is done. If reading binary data, the raw bytes are wrapped
 *	in a Tcl byte array object. Otherwise, the raw bytes are converted to
 *	UTF-8 using the channel's current encoding and stored in a Tcl string
 *	object.
 *
 * Results:
 *	The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Size
DoReadChars(
    Channel *chanPtr,		/* The channel to read. */
    Tcl_Obj *objPtr,		/* Input data is stored in this object. */
    Tcl_Size toRead,		/* Maximum number of characters to store, or
				 * TCL_INDEX_NONE to read all available data (up to EOF or
				 * when channel blocks). */
    int allowShortReads,	/* Allow half-blocking (pipes,sockets) */
    int appendFlag)		/* If non-zero, data read from the channel
				 * will be appended to the object. Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    Tcl_Size copied;
    int result;
    Tcl_Encoding encoding = statePtr->encoding;
    int binaryMode;
#define UTF_EXPANSION_FACTOR	1024
    int factor = UTF_EXPANSION_FACTOR;

    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
	/* TODO: UpdateInterest not needed here? */
	UpdateInterest(chanPtr);
	Tcl_SetErrno(EILSEQ);
	return -1;
    }

    /*
     * Early out when next read will see eofchar.
     *
     * NOTE: See DoRead for argument that it's a bug (one we're keeping) to
     * have this escape before the one for zero-char read request.







|

















|















|
|










<








|







5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946

5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
    if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
	/*
	 * Update the notifier state so we don't block while there is still
	 * data in the buffers.
	 */

	UpdateInterest(chanPtr);
	return TCL_IO_FAILURE;
    }

    return DoReadChars(chanPtr, objPtr, toRead, 0, appendFlag);
}
/*
 *---------------------------------------------------------------------------
 *
 * DoReadChars --
 *
 *	Reads from the channel until the requested number of characters have
 *	been seen, EOF is seen, or the channel would block. EOL and EOF
 *	translation is done. If reading binary data, the raw bytes are wrapped
 *	in a Tcl byte array object. Otherwise, the raw bytes are converted to
 *	UTF-8 using the channel's current encoding and stored in a Tcl string
 *	object.
 *
 * Results:
 *	The number of characters read, or TCL_IO_FAILURE on error. Use Tcl_GetErrno() to
 *	retrieve the error code for the error that occurred.
 *
 * Side effects:
 *	May cause input to be buffered.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Size
DoReadChars(
    Channel *chanPtr,		/* The channel to read. */
    Tcl_Obj *objPtr,		/* Input data is stored in this object. */
    Tcl_Size toRead,		/* Maximum number of characters to store, or
				 * TCL_INDEX_NONE to read all available data (up to EOF or
				 * when channel blocks). */
    bool allowShortReads,	/* Allow half-blocking (pipes,sockets) */
    bool appendFlag)		/* If true, data read from the channel
				 * will be appended to the object. Otherwise,
				 * the data will replace the existing contents
				 * of the object. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr;
    Tcl_Size copied;
    int result;
    Tcl_Encoding encoding = statePtr->encoding;

#define UTF_EXPANSION_FACTOR	1024
    int factor = UTF_EXPANSION_FACTOR;

    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
	/* TODO: UpdateInterest not needed here? */
	UpdateInterest(chanPtr);
	Tcl_SetErrno(EILSEQ);
	return TCL_IO_FAILURE;
    }

    /*
     * Early out when next read will see eofchar.
     *
     * NOTE: See DoRead for argument that it's a bug (one we're keeping) to
     * have this escape before the one for zero-char read request.
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    TclChannelPreserve((Tcl_Channel)chanPtr);

    binaryMode = (encoding == GetBinaryEncoding())
	    && (statePtr->inputTranslation == TCL_TRANSLATE_LF)
	    && (statePtr->inEofChar == '\0');

    if (appendFlag) {
	if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL))) {
	    binaryMode = 0;
	}
    } else {
	if (binaryMode) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);
	}







|





|







5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
    /*
     * This operation should occur at the top of a channel stack.
     */

    chanPtr = statePtr->topChanPtr;
    TclChannelPreserve((Tcl_Channel)chanPtr);

    bool binaryMode = (encoding == GetBinaryEncoding())
	    && (statePtr->inputTranslation == TCL_TRANSLATE_LF)
	    && (statePtr->inEofChar == '\0');

    if (appendFlag) {
	if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL))) {
	    binaryMode = false;
	}
    } else {
	if (binaryMode) {
	    Tcl_SetByteArrayLength(objPtr, 0);
	} else {
	    Tcl_SetObjLength(objPtr, 0);
	}
6140
6141
6142
6143
6144
6145
6146

6147
6148
6149
6150
6151
6152
6153
	 * like [read] can also return an error.
	*/
	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
	Tcl_SetErrno(EILSEQ);
	copied = -1;
    }
    TclChannelRelease((Tcl_Channel)chanPtr);

    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --







>







6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
	 * like [read] can also return an error.
	*/
	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
	Tcl_SetErrno(EILSEQ);
	copied = -1;
    }
    TclChannelRelease((Tcl_Channel)chanPtr);

    return copied;
}

/*
 *---------------------------------------------------------------------------
 *
 * ReadBytes --
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603

	    if (nextPtr->nextRemoved < srcLen) {
		Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	    }

	    nextPtr->nextRemoved -= srcLen;
	    memcpy(RemovePoint(nextPtr), src, srcLen);
	    RecycleBuffer(statePtr, bufPtr, 0);
	    statePtr->inQueueHead = nextPtr;
	    Tcl_SetObjLength(objPtr, numBytes);
	    return ReadChars(statePtr, objPtr, charsToRead, factorPtr);
	}

	statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;








|







6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602

	    if (nextPtr->nextRemoved < srcLen) {
		Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough");
	    }

	    nextPtr->nextRemoved -= srcLen;
	    memcpy(RemovePoint(nextPtr), src, srcLen);
	    RecycleBuffer(statePtr, bufPtr, false);
	    statePtr->inQueueHead = nextPtr;
	    Tcl_SetObjLength(objPtr, numBytes);
	    return ReadChars(statePtr, objPtr, charsToRead, factorPtr);
	}

	statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;

6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return TCL_ERROR;
    }

    result = FlushChannel(NULL, chanPtr, 0);
    if (result != 0) {
	return TCL_ERROR;
    }

    return TCL_OK;
}








|







6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940

    chanPtr = statePtr->topChanPtr;

    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
	return TCL_ERROR;
    }

    result = FlushChannel(NULL, chanPtr, false);
    if (result != 0) {
	return TCL_ERROR;
    }

    return TCL_OK;
}

6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
 *----------------------------------------------------------------------
 */

static void
DiscardInputQueued(
    ChannelState *statePtr,	/* Channel on which to discard the queued
				 * input. */
    int discardSavedBuffers)	/* If non-zero, discard all buffers including
				 * last one. */
{
    ChannelBuffer *bufPtr, *nxtPtr;
				/* Loop variables. */

    bufPtr = statePtr->inQueueHead;
    statePtr->inQueueHead = NULL;







|







6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
 *----------------------------------------------------------------------
 */

static void
DiscardInputQueued(
    ChannelState *statePtr,	/* Channel on which to discard the queued
				 * input. */
    bool discardSavedBuffers)	/* If true, discard all buffers including
				 * last one. */
{
    ChannelBuffer *bufPtr, *nxtPtr;
				/* Loop variables. */

    bufPtr = statePtr->inQueueHead;
    statePtr->inQueueHead = NULL;
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
				/* The real IO channel. */
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int inputBuffered, outputBuffered;
				/* # bytes held in buffers. */
    int result;			/* Of device driver operations. */
    long long curPos;		/* Position on the device. */
    int wasAsync;		/* Was the channel nonblocking before the seek
				 * operation? If so, must restore to
				 * non-blocking mode after the seek. */

    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return -1;
    }








|







7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
				/* The real IO channel. */
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    int inputBuffered, outputBuffered;
				/* # bytes held in buffers. */
    int result;			/* Of device driver operations. */
    long long curPos;		/* Position on the device. */
    bool wasAsync;		/* Was the channel nonblocking before the seek
				 * operation? If so, must restore to
				 * non-blocking mode after the seek. */

    if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
	return -1;
    }

7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
    /*
     * If the channel is in asynchronous output mode, switch it back to
     * synchronous mode and cancel any async flush that may be scheduled.
     * After the flush, the channel will be put back into asynchronous output
     * mode.
     */

    wasAsync = 0;
    if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
	wasAsync = 1;
	result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
	if (result != 0) {
	    return -1;
	}
	ResetFlag(statePtr, CHANNEL_NONBLOCKING);
	if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	}
    }

    /*
     * If the flush fails we cannot recover the original position. In that
     * case the seek is not attempted because we do not know where the access
     * position is - instead we return the error. FlushChannel has already
     * called Tcl_SetErrno() to report the error upwards. If the flush
     * succeeds we do the seek also.
     */

    if (FlushChannel(NULL, chanPtr, 0) != 0) {
	curPos = -1;
    } else {
	/*
	 * Now seek to the new position in the channel as requested by the
	 * caller.
	 */








|

|


















|







7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
    /*
     * If the channel is in asynchronous output mode, switch it back to
     * synchronous mode and cancel any async flush that may be scheduled.
     * After the flush, the channel will be put back into asynchronous output
     * mode.
     */

    wasAsync = false;
    if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
	wasAsync = true;
	result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
	if (result != 0) {
	    return -1;
	}
	ResetFlag(statePtr, CHANNEL_NONBLOCKING);
	if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	}
    }

    /*
     * If the flush fails we cannot recover the original position. In that
     * case the seek is not attempted because we do not know where the access
     * position is - instead we return the error. FlushChannel has already
     * called Tcl_SetErrno() to report the error upwards. If the flush
     * succeeds we do the seek also.
     */

    if (FlushChannel(NULL, chanPtr, false) != 0) {
	curPos = -1;
    } else {
	/*
	 * Now seek to the new position in the channel as requested by the
	 * caller.
	 */

7563
7564
7565
7566
7567
7568
7569
7570

7571
7572
7573
7574
7575
7576
7577
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclChanIsBinary(
    Tcl_Channel chan)		/* Does this channel have EOF? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return ((statePtr->encoding == GetBinaryEncoding()) && !statePtr->inEofChar







<
>







7562
7563
7564
7565
7566
7567
7568

7569
7570
7571
7572
7573
7574
7575
7576
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclChanIsBinary(
    Tcl_Channel chan)		/* Does this channel have EOF? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return ((statePtr->encoding == GetBinaryEncoding()) && !statePtr->inEofChar
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616

7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627

7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
Tcl_Eof(
    Tcl_Channel chan)		/* Does this channel have EOF? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
	return 0;
    }
    return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelGetBlockingMode --
 *
 *	Returns 1 if the channel is in blocking mode (default), 0 otherwise.

 *
 * Results:
 *	1 or 0, always.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclChannelGetBlockingMode(
    Tcl_Channel chan)
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBlocked --
 *







|

|







|
>


|







<
>






|







7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626

7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
Tcl_Eof(
    Tcl_Channel chan)		/* Does this channel have EOF? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
	return false;
    }
    return GotFlag(statePtr, CHANNEL_EOF) ? true : false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelGetBlockingMode --
 *
 *	Returns true if the channel is in blocking mode (default), false
 *	otherwise.
 *
 * Results:
 *	true or false.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclChannelGetBlockingMode(
    Tcl_Channel chan)
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return !GotFlag(statePtr, CHANNEL_NONBLOCKING);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBlocked --
 *
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
int
Tcl_InputBlocked(
    Tcl_Channel chan)		/* Is this channel blocked? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return GotFlag(statePtr, CHANNEL_BLOCKED) ? 1 : 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBuffered --
 *







|







7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
int
Tcl_InputBlocked(
    Tcl_Channel chan)		/* Is this channel blocked? */
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return GotFlag(statePtr, CHANNEL_BLOCKED) ? true : false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBuffered --
 *
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
    statePtr->bufSize = sz;

    /*
     * If bufsize changes, need to get rid of old utility buffer.
     */

    if (statePtr->saveInBufPtr != NULL) {
	RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1);
	statePtr->saveInBufPtr = NULL;
    }
    if ((statePtr->inQueueHead != NULL)
	    && (statePtr->inQueueHead->nextPtr == NULL)
	    && IsBufferEmpty(statePtr->inQueueHead)) {
	RecycleBuffer(statePtr, statePtr->inQueueHead, 1);
	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }
}

/*
 *----------------------------------------------------------------------







|





|







7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
    statePtr->bufSize = sz;

    /*
     * If bufsize changes, need to get rid of old utility buffer.
     */

    if (statePtr->saveInBufPtr != NULL) {
	RecycleBuffer(statePtr, statePtr->saveInBufPtr, true);
	statePtr->saveInBufPtr = NULL;
    }
    if ((statePtr->inQueueHead != NULL)
	    && (statePtr->inQueueHead->nextPtr == NULL)
	    && IsBufferEmpty(statePtr->inQueueHead)) {
	RecycleBuffer(statePtr, statePtr->inQueueHead, true);
	statePtr->inQueueHead = NULL;
	statePtr->inQueueTail = NULL;
    }
}

/*
 *----------------------------------------------------------------------
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
    /*
     * If we are flushing in the background, be sure to call FlushChannel for
     * writable events. Note that we have to discard the writable event so we
     * don't call any write handlers before the flush is complete.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	if (0 == FlushChannel(NULL, chanPtr, 1)) {
	    mask &= ~TCL_WRITABLE;
	}
    }

    /*
     * Add this invocation to the list of recursive invocations of
     * Tcl_NotifyChannel.







|







8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
    /*
     * If we are flushing in the background, be sure to call FlushChannel for
     * writable events. Note that we have to discard the writable event so we
     * don't call any write handlers before the flush is complete.
     */

    if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
	if (0 == FlushChannel(NULL, chanPtr, true)) {
	    mask &= ~TCL_WRITABLE;
	}
    }

    /*
     * Add this invocation to the list of recursive invocations of
     * Tcl_NotifyChannel.
9634
9635
9636
9637
9638
9639
9640
9641
9642
9643
9644
9645
9646
9647
9648
    if (inStatePtr->inQueueTail == tail) {
	inStatePtr->inQueueTail = bufPtr;
    }
    if (bufPtr == NULL) {
	inStatePtr->inQueueTail = NULL;
    }

    int code = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0);
    if (code) {
	MBError(csPtr, TCL_WRITABLE, code);
	return TCL_ERROR;
    }
    if (csPtr->toRead == 0 || GotFlag(inStatePtr, CHANNEL_EOF)) {
	return TCL_OK;
    }







|







9634
9635
9636
9637
9638
9639
9640
9641
9642
9643
9644
9645
9646
9647
9648
    if (inStatePtr->inQueueTail == tail) {
	inStatePtr->inQueueTail = bufPtr;
    }
    if (bufPtr == NULL) {
	inStatePtr->inQueueTail = NULL;
    }

    int code = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, false);
    if (code) {
	MBError(csPtr, TCL_WRITABLE, code);
	return TCL_ERROR;
    }
    if (csPtr->toRead == 0 || GotFlag(inStatePtr, CHANNEL_EOF)) {
	return TCL_OK;
    }
9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
    ChannelBuffer *bufPtr = outStatePtr->curOutPtr;
    int errorCode;

    if (bufPtr && BytesLeft(bufPtr)) {
	/* If we start with unflushed bytes in the destination
	 * channel, flush them out of the way first. */

	errorCode = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0);
	if (errorCode != 0) {
	    MBError(csPtr, TCL_WRITABLE, errorCode);
	    return TCL_ERROR;
	}
    }

    if (csPtr->cmdPtr) {







|







9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
    ChannelBuffer *bufPtr = outStatePtr->curOutPtr;
    int errorCode;

    if (bufPtr && BytesLeft(bufPtr)) {
	/* If we start with unflushed bytes in the destination
	 * channel, flush them out of the way first. */

	errorCode = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, false);
	if (errorCode != 0) {
	    MBError(csPtr, TCL_WRITABLE, errorCode);
	    return TCL_ERROR;
	}
    }

    if (csPtr->cmdPtr) {
9774
9775
9776
9777
9778
9779
9780
9781
9782
9783
9784
9785
9786
9787
9788
9789
	    }

	    if (moveBytes) {
		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
	    } else {
		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
			,0 /* No append */);
		/*
		 * In case of a recoverable encoding error, any data before
		 * the error should be written. This data is in the bufObj.
		 * Program flow for this case:
		 * - Check, if there are any remaining bytes to write
		 * - If yes, simulate a successful read to write them out
		 * - Come back here by the outer loop and read again







|
|







9774
9775
9776
9777
9778
9779
9780
9781
9782
9783
9784
9785
9786
9787
9788
9789
	    }

	    if (moveBytes) {
		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
	    } else {
		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
			!GotFlag(inStatePtr, CHANNEL_NONBLOCKING),
			false /* No append */);
		/*
		 * In case of a recoverable encoding error, any data before
		 * the error should be written. This data is in the bufObj.
		 * Program flow for this case:
		 * - Check, if there are any remaining bytes to write
		 * - If yes, simulate a successful read to write them out
		 * - Come back here by the outer loop and read again
10033
10034
10035
10036
10037
10038
10039
10040
10041
10042
10043
10044
10045
10046
10047
 */

static Tcl_Size
DoRead(
    Channel *chanPtr,		/* The channel from which to read. */
    char *dst,			/* Where to store input read. */
    Tcl_Size bytesToRead,	/* Maximum number of bytes to read. */
    int allowShortReads)	/* Allow half-blocking (pipes,sockets) */
{
    ChannelState *statePtr = chanPtr->state;
    char *p = dst;

    /*
     * Early out when we know a read will get the eofchar.
     *







|







10033
10034
10035
10036
10037
10038
10039
10040
10041
10042
10043
10044
10045
10046
10047
 */

static Tcl_Size
DoRead(
    Channel *chanPtr,		/* The channel from which to read. */
    char *dst,			/* Where to store input read. */
    Tcl_Size bytesToRead,	/* Maximum number of bytes to read. */
    bool allowShortReads)	/* Allow half-blocking (pipes,sockets) */
{
    ChannelState *statePtr = chanPtr->state;
    char *p = dst;

    /*
     * Early out when we know a read will get the eofchar.
     *
10213
10214
10215
10216
10217
10218
10219
10220
10221
10222
10223
10224
10225
10226
10227
	}

	if (IsBufferEmpty(bufPtr)) {
	    statePtr->inQueueHead = bufPtr->nextPtr;
	    if (statePtr->inQueueHead == NULL) {
		statePtr->inQueueTail = NULL;
	    }
	    RecycleBuffer(statePtr, bufPtr, 0);
	    bufPtr = statePtr->inQueueHead;
	}

	if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads)
		&& GotFlag(statePtr, CHANNEL_BLOCKED)) {
	    break;
	}







|







10213
10214
10215
10216
10217
10218
10219
10220
10221
10222
10223
10224
10225
10226
10227
	}

	if (IsBufferEmpty(bufPtr)) {
	    statePtr->inQueueHead = bufPtr->nextPtr;
	    if (statePtr->inQueueHead == NULL) {
		statePtr->inQueueTail = NULL;
	    }
	    RecycleBuffer(statePtr, bufPtr, false);
	    bufPtr = statePtr->inQueueHead;
	}

	if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads)
		&& GotFlag(statePtr, CHANNEL_BLOCKED)) {
	    break;
	}
10287
10288
10289
10290
10291
10292
10293
10294
10295
10296
10297
10298
10299
10300
10301
 *	translations to be performed, and no inline signals to respond to.
 *
 * Result:
 *	True if copying would be lossless.
 *
 *----------------------------------------------------------------------
 */
int
Lossless(
    ChannelState *inStatePtr,
    ChannelState *outStatePtr,
    long long toRead)
{
    return inStatePtr->inEofChar == '\0'	/* No eofChar to stop input */
	&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF







|







10287
10288
10289
10290
10291
10292
10293
10294
10295
10296
10297
10298
10299
10300
10301
 *	translations to be performed, and no inline signals to respond to.
 *
 * Result:
 *	True if copying would be lossless.
 *
 *----------------------------------------------------------------------
 */
static bool
Lossless(
    ChannelState *inStatePtr,
    ChannelState *outStatePtr,
    long long toRead)
{
    return inStatePtr->inEofChar == '\0'	/* No eofChar to stop input */
	&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
10421
10422
10423
10424
10425
10426
10427
10428
10429
10430
10431
10432
10433
10434
10435
10436
10437
10438
10439

10440
10441
10442
10443
10444
10445
10446
10447
10448
10449

static int
StackSetBlockMode(
    Channel *chanPtr,		/* Channel to modify. */
    int mode)			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{
    int result = 0;
    Tcl_DriverBlockModeProc *blockModeProc;
    ChannelState *statePtr = chanPtr->state;

    /*
     * Start at the top of the channel stack
     * TODO: Examine what can go wrong when blockModeProc calls
     * disturb the stacking state of the channel.
     */

    chanPtr = statePtr->topChanPtr;
    while (chanPtr != NULL) {

	blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr);
	if (blockModeProc != NULL) {
	    result = blockModeProc(chanPtr->instanceData, mode);
	    if (result != 0) {
		Tcl_SetErrno(result);
		return result;
	    }
	}
	chanPtr = chanPtr->downChanPtr;
    }







<
<










>
|

|







10421
10422
10423
10424
10425
10426
10427


10428
10429
10430
10431
10432
10433
10434
10435
10436
10437
10438
10439
10440
10441
10442
10443
10444
10445
10446
10447
10448

static int
StackSetBlockMode(
    Channel *chanPtr,		/* Channel to modify. */
    int mode)			/* One of TCL_MODE_BLOCKING or
				 * TCL_MODE_NONBLOCKING. */
{


    ChannelState *statePtr = chanPtr->state;

    /*
     * Start at the top of the channel stack
     * TODO: Examine what can go wrong when blockModeProc calls
     * disturb the stacking state of the channel.
     */

    chanPtr = statePtr->topChanPtr;
    while (chanPtr != NULL) {
	Tcl_DriverBlockModeProc *blockModeProc =
		Tcl_ChannelBlockModeProc(chanPtr->typePtr);
	if (blockModeProc != NULL) {
	    int result = blockModeProc(chanPtr->instanceData, mode);
	    if (result != 0) {
		Tcl_SetErrno(result);
		return result;
	    }
	}
	chanPtr = chanPtr->downChanPtr;
    }
10629
10630
10631
10632
10633
10634
10635
10636
10637
10638
10639
10640
10641
10642
10643
 *
 * Tcl_IsChannelRegistered --
 *
 *	Checks whether the channel is associated with the interp. See also
 *	Tcl_RegisterChannel and Tcl_UnregisterChannel.
 *
 * Results:
 *	0 if the channel is not registered in the interpreter, 1 else.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|







10628
10629
10630
10631
10632
10633
10634
10635
10636
10637
10638
10639
10640
10641
10642
 *
 * Tcl_IsChannelRegistered --
 *
 *	Checks whether the channel is associated with the interp. See also
 *	Tcl_RegisterChannel and Tcl_UnregisterChannel.
 *
 * Results:
 *	false if the channel is not registered in the interpreter, true else.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

10657
10658
10659
10660
10661
10662
10663
10664
10665
10666
10667
10668
10669
10670
10671
10672
10673
10674
10675
10676
10677
10678
10679
10680
10681
     */

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    statePtr = chanPtr->state;

    hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
    if (hTblPtr == NULL) {
	return 0;
    }
    hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
    if (hPtr == NULL) {
	return 0;
    }
    if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
	return 0;
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelShared --
 *







|



|


|


|







10656
10657
10658
10659
10660
10661
10662
10663
10664
10665
10666
10667
10668
10669
10670
10671
10672
10673
10674
10675
10676
10677
10678
10679
10680
     */

    chanPtr = ((Channel *) chan)->state->bottomChanPtr;
    statePtr = chanPtr->state;

    hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
    if (hTblPtr == NULL) {
	return false;
    }
    hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
    if (hPtr == NULL) {
	return false;
    }
    if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
	return false;
    }

    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsChannelShared --
 *
10706
10707
10708
10709
10710
10711
10712
10713
10714
10715
10716
10717
10718
10719
10720
 * Tcl_IsChannelExisting --
 *
 *	Checks whether a channel of the given name exists in the
 *	(thread)-global list of all channels. See Tcl_GetChannelNamesEx for
 *	function exposed at the Tcl level.
 *
 * Results:
 *	A boolean value (0 = Does not exist, 1 = Does exist).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */








|







10705
10706
10707
10708
10709
10710
10711
10712
10713
10714
10715
10716
10717
10718
10719
 * Tcl_IsChannelExisting --
 *
 *	Checks whether a channel of the given name exists in the
 *	(thread)-global list of all channels. See Tcl_GetChannelNamesEx for
 *	function exposed at the Tcl level.
 *
 * Results:
 *	A boolean value (false = Does not exist, true = Does exist).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

10736
10737
10738
10739
10740
10741
10742
10743
10744
10745
10746
10747
10748
10749
10750
10751
10752
10753
10754
	    name = "stderr";
	} else {
	    name = statePtr->channelName;
	}

	if ((*chanName == *name) &&
		(memcmp(name, chanName, chanNameLen + 1) == 0)) {
	    return 1;
	}
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelName --
 *







|



|







10735
10736
10737
10738
10739
10740
10741
10742
10743
10744
10745
10746
10747
10748
10749
10750
10751
10752
10753
	    name = "stderr";
	} else {
	    name = statePtr->channelName;
	}

	if ((*chanName == *name) &&
		(memcmp(name, chanName, chanNameLen + 1) == 0)) {
	    return true;
	}
    }

    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ChannelName --
 *
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281
11282
11283
11284
11285
11286
11287
11288
11289
11290
11291
11292
11293
11294
11295
11296
11297
11298
11299
    /*
     * New level/code information is spliced into the first occurrence of
     * -level, -code, further occurrences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    int lignore = 0, cignore = 0;
    int i, j;
    for (i=0, j=0; i<numOptions; i+=2) {
	if (0 == strcmp(TclGetString(lv[i]), "-level")) {
	    if (newlevel >= 0) {
		lvn[j++] = lv[i];
		lvn[j++] = Tcl_NewWideIntObj(newlevel);
		newlevel = -1;
		lignore = 1;
		continue;
	    } else if (lignore) {
		continue;
	    }
	} else if (0 == strcmp(TclGetString(lv[i]), "-code")) {
	    if (newcode >= 0) {
		lvn[j++] = lv[i];
		lvn[j++] = Tcl_NewWideIntObj(newcode);
		newcode = -1;
		cignore = 1;
		continue;
	    } else if (cignore) {
		continue;
	    }
	}

	/*







|







|









|







11266
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281
11282
11283
11284
11285
11286
11287
11288
11289
11290
11291
11292
11293
11294
11295
11296
11297
11298
    /*
     * New level/code information is spliced into the first occurrence of
     * -level, -code, further occurrences are ignored. The options cannot be
     * not present, we would not come here. Options which are ok are simply
     * copied over.
     */

    bool lignore = false, cignore = false;
    int i, j;
    for (i=0, j=0; i<numOptions; i+=2) {
	if (0 == strcmp(TclGetString(lv[i]), "-level")) {
	    if (newlevel >= 0) {
		lvn[j++] = lv[i];
		lvn[j++] = Tcl_NewWideIntObj(newlevel);
		newlevel = -1;
		lignore = true;
		continue;
	    } else if (lignore) {
		continue;
	    }
	} else if (0 == strcmp(TclGetString(lv[i]), "-code")) {
	    if (newcode >= 0) {
		lvn[j++] = lv[i];
		lvn[j++] = Tcl_NewWideIntObj(newcode);
		newcode = -1;
		cignore = true;
		continue;
	    } else if (cignore) {
		continue;
	    }
	}

	/*
Changes to generic/tclIOCmd.c.
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

/*
 * Thread local storage used to maintain a per-thread stdout channel obj.
 * It must be per-thread because of std channel limitations.
 */

typedef struct ThreadSpecificData_IOCommands {
    int initialized;		/* Set to 1 when the module is initialized. */
    Tcl_Obj *stdoutObjPtr;	/* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Key for looking up the table of registered TCP accept callbacks, a hash







|







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

/*
 * Thread local storage used to maintain a per-thread stdout channel obj.
 * It must be per-thread because of std channel limitations.
 */

typedef struct ThreadSpecificData_IOCommands {
    bool initialized;		/* True when the module is initialized. */
    Tcl_Obj *stdoutObjPtr;	/* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * Key for looking up the table of registered TCP accept callbacks, a hash
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->stdoutObjPtr != NULL) {
	Tcl_DecrRefCount(tsdPtr->stdoutObjPtr);
	tsdPtr->stdoutObjPtr = NULL;
    }
    tsdPtr->initialized = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutsObjCmd --
 *







|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->stdoutObjPtr != NULL) {
	Tcl_DecrRefCount(tsdPtr->stdoutObjPtr);
	tsdPtr->stdoutObjPtr = NULL;
    }
    tsdPtr->initialized = false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutsObjCmd --
 *
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
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    Tcl_Obj *chanObjPtr = NULL;	/* channel object. */
    int newline;		/* Add a newline at end? */
    Tcl_Size result;		/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */

    switch (objc) {
    case 2:			/* [puts $x] */
	string = objv[1];
	newline = 1;
	break;

    case 3:			/* [puts -nonewline $x] or [puts $chan $x] */
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    newline = 0;
	} else {
	    newline = 1;
	    chanObjPtr = objv[1];
	}
	string = objv[2];
	break;

    case 4:			/* [puts -nonewline $chan $x] or
				 * [puts $chan $x nonewline] */
	newline = 0;
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    chanObjPtr = objv[2];
	    string = objv[3];
	    break;
	}
	TCL_FALLTHROUGH();
    default:			/* [puts] or
				 * [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string");
	return TCL_ERROR;
    }

    if (chanObjPtr == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (!tsdPtr->initialized) {
	    tsdPtr->initialized = 1;
	    TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout");
	    Tcl_IncrRefCount(tsdPtr->stdoutObjPtr);
	    Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
	}
	chanObjPtr = tsdPtr->stdoutObjPtr;
    }
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_WRITABLE)) {
	TclPrintfResult(interp, "channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr));
	return TCL_ERROR;
    }

    TclChannelPreserve(chan);
    result = Tcl_WriteObj(chan, string);
    if (result == TCL_INDEX_NONE) {
	goto error;
    }
    if (newline != 0) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result == TCL_INDEX_NONE) {
	    goto error;
	}
    }
    TclChannelRelease(chan);
    return TCL_OK;







|






|




|

|







|
















|




















|







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
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to puts on. */
    Tcl_Obj *string;		/* String to write. */
    Tcl_Obj *chanObjPtr = NULL;	/* channel object. */
    bool newline;		/* Add a newline at end? */
    Tcl_Size result;		/* Result of puts operation. */
    int mode;			/* Mode in which channel is opened. */

    switch (objc) {
    case 2:			/* [puts $x] */
	string = objv[1];
	newline = true;
	break;

    case 3:			/* [puts -nonewline $x] or [puts $chan $x] */
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    newline = false;
	} else {
	    newline = true;
	    chanObjPtr = objv[1];
	}
	string = objv[2];
	break;

    case 4:			/* [puts -nonewline $chan $x] or
				 * [puts $chan $x nonewline] */
	newline = false;
	if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	    chanObjPtr = objv[2];
	    string = objv[3];
	    break;
	}
	TCL_FALLTHROUGH();
    default:			/* [puts] or
				 * [puts some bad number of arguments...] */
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string");
	return TCL_ERROR;
    }

    if (chanObjPtr == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

	if (!tsdPtr->initialized) {
	    tsdPtr->initialized = true;
	    TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout");
	    Tcl_IncrRefCount(tsdPtr->stdoutObjPtr);
	    Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL);
	}
	chanObjPtr = tsdPtr->stdoutObjPtr;
    }
    if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!(mode & TCL_WRITABLE)) {
	TclPrintfResult(interp, "channel \"%s\" wasn't opened for writing",
		TclGetString(chanObjPtr));
	return TCL_ERROR;
    }

    TclChannelPreserve(chan);
    result = Tcl_WriteObj(chan, string);
    if (result == TCL_INDEX_NONE) {
	goto error;
    }
    if (newline) {
	result = Tcl_WriteChars(chan, "\n", 1);
	if (result == TCL_INDEX_NONE) {
	    goto error;
	}
    }
    TclChannelRelease(chan);
    return TCL_OK;
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
Tcl_ReadObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int newline, i;		/* Discard newline at end? */
    Tcl_WideInt toRead;		/* How many bytes to read? */
    Tcl_Size charactersRead;	/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;







|







366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
Tcl_ReadObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    bool newline;		/* Discard newline at end? */
    Tcl_WideInt toRead;		/* How many bytes to read? */
    Tcl_Size charactersRead;	/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
	 */

	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channel");
	return TCL_ERROR;
    }

    i = 1;
    newline = 0;
    if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	newline = 1;
	i++;
    }

    if (i == objc) {
	goto argerror;
    }








|
|

|







389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
	 */

	iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channel");
	return TCL_ERROR;
    }

    int i = 1;
    newline = false;
    if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
	newline = true;
	i++;
    }

    if (i == objc) {
	goto argerror;
    }

460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	Tcl_Size length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}







|







460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && newline) {
	const char *result;
	Tcl_Size length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
900
901
902
903
904
905
906

907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *resultPtr;
    const char **argv;		/* An array for the string arguments. Stored
				 * on the _Tcl_ stack. */
    const char *string;
    Tcl_Channel chan;

    int argc, background, index, keepNewline, result, skip, ignoreStderr;
    Tcl_Size length;
    static const char *const options[] = {
	"-ignorestderr", "-keepnewline", "-encoding", "--", NULL
    };
    enum execOptionsEnum {
	EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_ENCODING, EXEC_LAST
    };
    Tcl_Obj *encodingObj = NULL;

    /*
     * Check for any leading option arguments.
     */

    keepNewline = 0;
    ignoreStderr = 0;
    for (skip = 1; skip < objc; skip++) {
	string = TclGetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_LAST) {
	    skip++;
	    break;
	}
	switch (index) {
	case EXEC_KEEPNEWLINE:
	    keepNewline = 1;
	    break;
	case EXEC_IGNORESTDERR:
	    ignoreStderr = 1;
	    break;
	case EXEC_ENCODING:
	    if (++skip >= objc) {
		TclPrintfResult(interp, "No value given for option -encoding.");
		return TCL_ERROR;
	    } else {
		Tcl_Encoding encoding;







>
|













|
|















|


|







900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Obj *resultPtr;
    const char **argv;		/* An array for the string arguments. Stored
				 * on the _Tcl_ stack. */
    const char *string;
    Tcl_Channel chan;
    int argc, index, result, skip;
    bool background, keepNewline, ignoreStderr;
    Tcl_Size length;
    static const char *const options[] = {
	"-ignorestderr", "-keepnewline", "-encoding", "--", NULL
    };
    enum execOptionsEnum {
	EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_ENCODING, EXEC_LAST
    };
    Tcl_Obj *encodingObj = NULL;

    /*
     * Check for any leading option arguments.
     */

    keepNewline = false;
    ignoreStderr = false;
    for (skip = 1; skip < objc; skip++) {
	string = TclGetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_LAST) {
	    skip++;
	    break;
	}
	switch (index) {
	case EXEC_KEEPNEWLINE:
	    keepNewline = true;
	    break;
	case EXEC_IGNORESTDERR:
	    ignoreStderr = true;
	    break;
	case EXEC_ENCODING:
	    if (++skip >= objc) {
		TclPrintfResult(interp, "No value given for option -encoding.");
		return TCL_ERROR;
	    } else {
		Tcl_Encoding encoding;
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */

    background = 0;
    string = TclGetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
	background = 1;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large enough
     * to hold the argc arguments plus 1 extra for the zero end-of-argv word.
     */








|



|







963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */

    background = false;
    string = TclGetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
	background = true;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large enough
     * to hold the argc arguments plus 1 extra for the zero end-of-argv word.
     */

1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));

    /*
     * If the last character of the result is a newline, then remove the
     * newline character.
     */

    if (keepNewline == 0) {
	string = TclGetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);








|







1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
    Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));

    /*
     * If the last character of the result is a newline, then remove the
     * newline character.
     */

    if (!keepNewline) {
	string = TclGetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155
1156
1157
int
Tcl_OpenObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int pipeline, prot;

    const char *modeString, *what;
    Tcl_Channel chan;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
	return TCL_ERROR;
    }







|
>







1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
int
Tcl_OpenObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    bool pipeline;
    int prot;
    const char *modeString, *what;
    Tcl_Channel chan;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
	return TCL_ERROR;
    }
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
	    if ((code == TCL_ERROR)
		    && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
		return TCL_ERROR;
	    }
	}
    }

    pipeline = 0;
    what = TclGetString(objv[1]);
    if (what[0] == '|') {
	pipeline = 1;
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {







|


|







1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
	    if ((code == TCL_ERROR)
		    && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
		return TCL_ERROR;
	    }
	}
    }

    pipeline = false;
    what = TclGetString(objv[1]);
    if (what[0] == '|') {
	pipeline = true;
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
1526
1527
1528
1529
1530
1531
1532
1533
1534

1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
	"-async", "-backlog", "-myaddr", "-myport", "-reuseaddr",
	"-reuseport", "-server", NULL
    };
    enum socketOptionsEnum {
	SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR,
	SKT_REUSEPORT, SKT_SERVER
    } optionIndex;
    int a, server = 0, myport = 0, async = 0, reusep = -1,
	reusea = -1, backlog = -1;

    unsigned int flags = 0;
    const char *host, *port, *myaddr = NULL;
    Tcl_Obj *script = NULL;
    Tcl_Channel chan;

    TclInitSockets();

    for (a = 1; a < objc; a++) {
	const char *arg = TclGetString(objv[a]);

	if (arg[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
		TCL_EXACT, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case SKT_ASYNC:
	    if (server == 1) {
		TclPrintfResult(interp,
			"cannot set -async option for server sockets");
		return TCL_ERROR;
	    }
	    async = 1;
	    break;
	case SKT_MYADDR:
	    a++;
	    if (a >= objc) {
		TclPrintfResult(interp, "no argument given for %s option",
			"-myaddr");
		return TCL_ERROR;







<
|
>



















|




|







1528
1529
1530
1531
1532
1533
1534

1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
	"-async", "-backlog", "-myaddr", "-myport", "-reuseaddr",
	"-reuseport", "-server", NULL
    };
    enum socketOptionsEnum {
	SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR,
	SKT_REUSEPORT, SKT_SERVER
    } optionIndex;

    int a, myport = 0, reusep = -1, reusea = -1, backlog = -1;
    bool server = false, async = false;
    unsigned int flags = 0;
    const char *host, *port, *myaddr = NULL;
    Tcl_Obj *script = NULL;
    Tcl_Channel chan;

    TclInitSockets();

    for (a = 1; a < objc; a++) {
	const char *arg = TclGetString(objv[a]);

	if (arg[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
		TCL_EXACT, &optionIndex) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (optionIndex) {
	case SKT_ASYNC:
	    if (server) {
		TclPrintfResult(interp,
			"cannot set -async option for server sockets");
		return TCL_ERROR;
	    }
	    async = true;
	    break;
	case SKT_MYADDR:
	    a++;
	    if (a >= objc) {
		TclPrintfResult(interp, "no argument given for %s option",
			"-myaddr");
		return TCL_ERROR;
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
	    myPortName = TclGetString(objv[a]);
	    if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	}
	case SKT_SERVER:
	    if (async == 1) {
		TclPrintfResult(interp,
			"cannot set -async option for server sockets");
		return TCL_ERROR;
	    }
	    server = 1;
	    a++;
	    if (a >= objc) {
		TclPrintfResult(interp, "no argument given for %s option",
			"-server");
		return TCL_ERROR;
	    }
	    script = objv[a];







|




|







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
	    myPortName = TclGetString(objv[a]);
	    if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
		return TCL_ERROR;
	    }
	    break;
	}
	case SKT_SERVER:
	    if (async) {
		TclPrintfResult(interp,
			"cannot set -async option for server sockets");
		return TCL_ERROR;
	    }
	    server = true;
	    a++;
	    if (a >= objc) {
		TclPrintfResult(interp, "no argument given for %s option",
			"-server");
		return TCL_ERROR;
	    }
	    script = objv[a];
Changes to generic/tclIOGT.c.
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
struct TransformChannelData {
    /*
     * General section. Data to integrate the transformation into the channel
     * system.
     */

    Tcl_Channel self;		/* Our own Channel handle. */
    int readIsFlushed;		/* Flag to note whether in.flushProc was
				 * called or not. */
    int eofPending;		/* Flag: EOF seen down, not raised up */
    int flags;			/* Currently CHANNEL_ASYNC or zero. */
    int watchMask;		/* Current watch/event/interest mask. */
    int mode;			/* Mode of parent channel, OR'ed combination
				 * of TCL_READABLE, TCL_WRITABLE. */
    Tcl_TimerToken timer;	/* Timer for automatic flushing of information
				 * sitting in an internal buffer. Required for
				 * full fileevent support. */







|

|







179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
struct TransformChannelData {
    /*
     * General section. Data to integrate the transformation into the channel
     * system.
     */

    Tcl_Channel self;		/* Our own Channel handle. */
    bool readIsFlushed;		/* Flag to note whether in.flushProc was
				 * called or not. */
    bool eofPending;		/* Flag: EOF seen down, not raised up */
    int flags;			/* Currently CHANNEL_ASYNC or zero. */
    int watchMask;		/* Current watch/event/interest mask. */
    int mode;			/* Mode of parent channel, OR'ed combination
				 * of TCL_READABLE, TCL_WRITABLE. */
    Tcl_TimerToken timer;	/* Timer for automatic flushing of information
				 * sitting in an internal buffer. Required for
				 * full fileevent support. */
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
     */

    dataPtr = (TransformChannelData *)Tcl_Alloc(sizeof(TransformChannelData));

    dataPtr->refCount = 1;
    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = 0;
    dataPtr->eofPending = 0;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }
    Tcl_DStringFree(&ds);

    dataPtr->watchMask = 0;







|
|







284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
     */

    dataPtr = (TransformChannelData *)Tcl_Alloc(sizeof(TransformChannelData));

    dataPtr->refCount = 1;
    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = false;
    dataPtr->eofPending = false;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }
    Tcl_DStringFree(&ds);

    dataPtr->watchMask = 0;
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
	ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF,
		P_PRESERVE);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);







|







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = true;
	ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF,
		P_PRESERVE);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	} else if (read == 0) {

	    /*
	     * Zero returned from Tcl_ReadRaw() always indicates EOF
	     * on the down channel.
	     */

	    dataPtr->eofPending = 1;
	    dataPtr->readIsFlushed = 1;
	    ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0,
		    TRANSMIT_IBUF, P_PRESERVE);

	    if (ResultEmpty(&dataPtr->result)) {
		/*
		 * We had nothing to flush.
		 */







|
|







739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
	} else if (read == 0) {

	    /*
	     * Zero returned from Tcl_ReadRaw() always indicates EOF
	     * on the down channel.
	     */

	    dataPtr->eofPending = true;
	    dataPtr->readIsFlushed = true;
	    ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0,
		    TRANSMIT_IBUF, P_PRESERVE);

	    if (ResultEmpty(&dataPtr->result)) {
		/*
		 * We had nothing to flush.
		 */
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
	    *errorCodePtr = EINVAL;
	    gotBytes = -1;
	    break;
	}
    } /* while toRead > 0 */

    if (gotBytes == 0) {
	dataPtr->eofPending = 0;
    }
    ReleaseData(dataPtr);
    return gotBytes;
}

/*
 *----------------------------------------------------------------------







|







769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
	    *errorCodePtr = EINVAL;
	    gotBytes = -1;
	    break;
	}
    } /* while toRead > 0 */

    if (gotBytes == 0) {
	dataPtr->eofPending = false;
    }
    ReleaseData(dataPtr);
    return gotBytes;
}

/*
 *----------------------------------------------------------------------
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
	dataPtr->eofPending = 0;
    }
    ReleaseData(dataPtr);

    /*
     * If we have a wide seek capability, we should stick with that.
     */








|
|







887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = false;
	dataPtr->eofPending = false;
    }
    ReleaseData(dataPtr);

    /*
     * If we have a wide seek capability, we should stick with that.
     */

Changes to generic/tclIORChan.c.
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    Tcl_Obj *methods;		/* Methods to append to command prefix */
    Tcl_Obj *name;		/* Name of the channel as created */

    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. */

    /*
     * 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







|







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    Tcl_Obj *methods;		/* Methods to append to command prefix */
    Tcl_Obj *name;		/* Name of the channel as created */

    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

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

    /*
     * 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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct {
    int code;			/* O: Ok/Fail of the cmd handler */
    char *msgStr;		/* O: Error message for handler failure */
    int mustFree;		/* O: True if msgStr is allocated, false if
				 * otherwise (static). */
} ForwardParamBase;

/*
 * Operation specific parameter/result structures. (These are "subtypes" of
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)







|







237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct {
    int code;			/* O: Ok/Fail of the cmd handler */
    char *msgStr;		/* O: Error message for handler failure */
    bool mustFree;		/* O: True if msgStr is allocated, false if
				 * otherwise (static). */
} ForwardParamBase;

/*
 * Operation specific parameter/result structures. (These are "subtypes" of
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

static void		ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
			    ForwardedOperation op, const void *param);
static int		ForwardProc(Tcl_Event *evPtr, int mask);
static void		SrcExitProc(void *clientData);

#define FreeReceivedError(p) \
	if ((p)->base.mustFree) {                               \
	    Tcl_Free((p)->base.msgStr);                           \
	}
#define PassReceivedErrorInterp(i,p) \
	if ((i) != NULL) {                                      \
	    Tcl_SetChannelErrorInterp((i),                      \
		    Tcl_NewStringObj((p)->base.msgStr, -1));    \
	}                                                       \
	FreeReceivedError(p)
#define PassReceivedError(c,p) \
	Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
	FreeReceivedError(p)
#define ForwardSetStaticError(p,emsg) \
	(p)->base.code = TCL_ERROR;                             \
	(p)->base.mustFree = 0;                                 \
	(p)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(p,emsg) \
	(p)->base.code = TCL_ERROR;                             \
	(p)->base.mustFree = 1;                                 \
	(p)->base.msgStr = (char *) (emsg)

static void		ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);

static ReflectedChannelMap *	GetThreadReflectedChannelMap(void);
static Tcl_ExitProc	DeleteThreadReflectedChannelMap;








|
|











|
|


|
|







387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

static void		ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
			    ForwardedOperation op, const void *param);
static int		ForwardProc(Tcl_Event *evPtr, int mask);
static void		SrcExitProc(void *clientData);

#define FreeReceivedError(p) \
	if ((p)->base.mustFree) {				\
	    Tcl_Free((p)->base.msgStr);				\
	}
#define PassReceivedErrorInterp(i,p) \
	if ((i) != NULL) {                                      \
	    Tcl_SetChannelErrorInterp((i),                      \
		    Tcl_NewStringObj((p)->base.msgStr, -1));    \
	}                                                       \
	FreeReceivedError(p)
#define PassReceivedError(c,p) \
	Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
	FreeReceivedError(p)
#define ForwardSetStaticError(p,emsg) \
	(p)->base.code = TCL_ERROR;				\
	(p)->base.mustFree = false;				\
	(p)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(p,emsg) \
	(p)->base.code = TCL_ERROR;				\
	(p)->base.mustFree = true;				\
	(p)->base.msgStr = (char *) (emsg)

static void		ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);

static ReflectedChannelMap *	GetThreadReflectedChannelMap(void);
static Tcl_ExitProc	DeleteThreadReflectedChannelMap;

792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
     * latter ensures that no pending events of this type are run on an
     * invalid channel.
     */

    ReflectEvent *e = (ReflectEvent *) ev;

    if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
	return 0;
    }
    return 1;
}
#endif

int
TclChanPostEventObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,







|

|







792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
     * latter ensures that no pending events of this type are run on an
     * invalid channel.
     */

    ReflectEvent *e = (ReflectEvent *) ev;

    if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
	return false;
    }
    return true;
}
#endif

int
TclChanPostEventObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
1034
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
1060
1061
1062
1063
1064
	Tcl_SetObjResult(interp, lv[lc-1]);
    }

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
    ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED;
}

int

TclChanCaughtErrorBypass(
    Tcl_Interp *interp,
    Tcl_Channel chan)
{
    Tcl_Obj *chanMsgObj = NULL;
    Tcl_Obj *interpMsgObj = NULL;
    Tcl_Obj *msgObj = NULL;

    /*
     * Get a bypassed error message from channel and/or interpreter, save the
     * reference, then kill the returned objects, if there were any. If there
     * are messages in both the channel has preference.
     */

    if ((chan == NULL) && (interp == NULL)) {
	return 0;
    }

    if (chan != NULL) {
	Tcl_GetChannelError(chan, &chanMsgObj);
    }
    if (interp != NULL) {
	Tcl_GetChannelErrorInterp(interp, &interpMsgObj);







<
>















|







1034
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
1060
1061
1062
1063
1064
	Tcl_SetObjResult(interp, lv[lc-1]);
    }

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
    ((Interp *) interp)->flags &= ~ERR_ALREADY_LOGGED;
}


bool
TclChanCaughtErrorBypass(
    Tcl_Interp *interp,
    Tcl_Channel chan)
{
    Tcl_Obj *chanMsgObj = NULL;
    Tcl_Obj *interpMsgObj = NULL;
    Tcl_Obj *msgObj = NULL;

    /*
     * Get a bypassed error message from channel and/or interpreter, save the
     * reference, then kill the returned objects, if there were any. If there
     * are messages in both the channel has preference.
     */

    if ((chan == NULL) && (interp == NULL)) {
	return false;
    }

    if (chan != NULL) {
	Tcl_GetChannelError(chan, &chanMsgObj);
    }
    if (interp != NULL) {
	Tcl_GetChannelErrorInterp(interp, &interpMsgObj);
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
    }

    /*
     * No message returned, nothing caught.
     */

    if (msgObj == NULL) {
	return 0;
    }

    UnmarshallErrorResult(interp, msgObj);

    Tcl_DecrRefCount(msgObj);
    return 1;
}

/*
 * Driver functions. ================================================
 */

/*







|





|







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

    /*
     * No message returned, nothing caught.
     */

    if (msgObj == NULL) {
	return false;
    }

    UnmarshallErrorResult(interp, msgObj);

    Tcl_DecrRefCount(msgObj);
    return true;
}

/*
 * Driver functions. ================================================
 */

/*
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198

    rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));

    /* rcPtr->chan: Assigned by caller. Dummy data here. */

    rcPtr->chan = NULL;
    rcPtr->interp = interp;
    rcPtr->dead = 0;
#if TCL_THREADS
    rcPtr->thread = Tcl_GetCurrentThread();
#endif
    rcPtr->mode = mode;
    rcPtr->interest = 0;		/* Initially no interest registered */

    rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);







|







2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198

    rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));

    /* rcPtr->chan: Assigned by caller. Dummy data here. */

    rcPtr->chan = NULL;
    rcPtr->interp = interp;
    rcPtr->dead = false;
#if TCL_THREADS
    rcPtr->thread = Tcl_GetCurrentThread();
#endif
    rcPtr->mode = mode;
    rcPtr->interest = 0;		/* Initially no interest registered */

    rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
MarkDead(
    ReflectedChannel *rcPtr)
{
    if (rcPtr->dead) {
	return;
    }
    CleanRefChannelInstance(rcPtr);
    rcPtr->dead = 1;
}

static void
DeleteReflectedChannelMap(
    void *clientData,		/* The per-interpreter data structure. */
    Tcl_Interp *interp)		/* The interpreter being deleted. */
{







|







2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
MarkDead(
    ReflectedChannel *rcPtr)
{
    if (rcPtr->dead) {
	return;
    }
    CleanRefChannelInstance(rcPtr);
    rcPtr->dead = true;
}

static void
DeleteReflectedChannelMap(
    void *clientData,		/* The per-interpreter data structure. */
    Tcl_Interp *interp)		/* The interpreter being deleted. */
{
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999

    if (!resultPtr) {
	return 1;
    }

    paramPtr->base.code = TCL_OK;
    paramPtr->base.msgStr = NULL;
    paramPtr->base.mustFree = 0;

    switch (evPtr->op) {
	/*
	 * The destination thread for the following operations is
	 * rcPtr->thread, which contains rcPtr->interp, the interp we have to
	 * call upon for the driver.
	 */







|







2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999

    if (!resultPtr) {
	return 1;
    }

    paramPtr->base.code = TCL_OK;
    paramPtr->base.msgStr = NULL;
    paramPtr->base.mustFree = false;

    switch (evPtr->op) {
	/*
	 * The destination thread for the following operations is
	 * rcPtr->thread, which contains rcPtr->interp, the interp we have to
	 * call upon for the driver.
	 */
Changes to generic/tclIORTrans.c.
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

    /*
     * NOTE (9): Should we have predefined shared literals for the method
     * names?
     */

    int mode;			/* Mask of R/W mode */
    int nonblocking;		/* Flag: Channel is blocking or not. */
    int readIsDrained;		/* Flag: Read buffers are flushed. */
    int eofPending;		/* Flag: EOF seen down, but not raised up */
    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */
    ResultBuffer result;
} ReflectedTransform;

/*
 * Structure of the table mapping from transform handles to reflected
 * transform (channels). Each interpreter which has the handler command for







|
|
|
|







148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

    /*
     * NOTE (9): Should we have predefined shared literals for the method
     * names?
     */

    int mode;			/* Mask of R/W mode */
    bool nonblocking;		/* Flag: Channel is blocking or not. */
    bool readIsDrained;		/* Flag: Read buffers are flushed. */
    bool eofPending;		/* Flag: EOF seen down, but not raised up */
    bool dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */
    ResultBuffer result;
} ReflectedTransform;

/*
 * Structure of the table mapping from transform handles to reflected
 * transform (channels). Each interpreter which has the handler command for
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct {
    int code;			/* O: Ok/Fail of the cmd handler */
    char *msgStr;		/* O: Error message for handler failure */
    int mustFree;		/* O: True if msgStr is allocated, false if
				 * otherwise (static). */
} ForwardParamBase;

/*
 * Operation specific parameter/result structures. (These are "subtypes" of
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)







|







245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct {
    int code;			/* O: Ok/Fail of the cmd handler */
    char *msgStr;		/* O: Error message for handler failure */
    bool mustFree;		/* O: True if msgStr is allocated, false if
				 * otherwise (static). */
} ForwardParamBase;

/*
 * Operation specific parameter/result structures. (These are "subtypes" of
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
	    Tcl_SetChannelError((c),					\
		    Tcl_NewStringObj((p)->base.msgStr, -1));		\
	    FreeReceivedError(p);					\
	} while (0)
#define ForwardSetStaticError(p,emsg) \
	do {								\
	    (p)->base.code = TCL_ERROR;					\
	    (p)->base.mustFree = 0;					\
	    (p)->base.msgStr = (char *) (emsg);				\
	} while (0)
#define ForwardSetDynamicError(p,emsg) \
	do {								\
	    (p)->base.code = TCL_ERROR;					\
	    (p)->base.mustFree = 1;					\
	    (p)->base.msgStr = (char *) (emsg);				\
	} while (0)

static void		ForwardSetObjError(ForwardParam *p,
			    Tcl_Obj *objPtr);
static ReflectedTransformMap *	GetThreadReflectedTransformMap(void);
static void		DeleteThreadReflectedTransformMap(







|





|







375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
	    Tcl_SetChannelError((c),					\
		    Tcl_NewStringObj((p)->base.msgStr, -1));		\
	    FreeReceivedError(p);					\
	} while (0)
#define ForwardSetStaticError(p,emsg) \
	do {								\
	    (p)->base.code = TCL_ERROR;					\
	    (p)->base.mustFree = false;					\
	    (p)->base.msgStr = (char *) (emsg);				\
	} while (0)
#define ForwardSetDynamicError(p,emsg) \
	do {								\
	    (p)->base.code = TCL_ERROR;					\
	    (p)->base.mustFree = true;					\
	    (p)->base.msgStr = (char *) (emsg);				\
	} while (0)

static void		ForwardSetObjError(ForwardParam *p,
			    Tcl_Obj *objPtr);
static ReflectedTransformMap *	GetThreadReflectedTransformMap(void);
static void		DeleteThreadReflectedTransformMap(
872
873
874
875
876
877
878
879

880
881
882
883
884
885
886
static int
ReflectClose(
    void *clientData,
    Tcl_Interp *interp,
    int flags)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
    int errorCode, errorCodeSet = 0;

    int result = TCL_OK;	/* Result code for 'close' */
    Tcl_Obj *resObj;		/* Result data for 'close' */
    ReflectedTransformMap *rtmPtr;
				/* Map of reflected transforms with handlers
				 * in this interp. */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */








|
>







872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
static int
ReflectClose(
    void *clientData,
    Tcl_Interp *interp,
    int flags)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
    int errorCode = 0;
    bool errorCodeSet = false;
    int result = TCL_OK;	/* Result code for 'close' */
    Tcl_Obj *resObj;		/* Result data for 'close' */
    ReflectedTransformMap *rtmPtr;
				/* Map of reflected transforms with handlers
				 * in this interp. */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */

935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
#if TCL_THREADS
	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
		Tcl_EventuallyFree(rtPtr,
			FreeReflectedTransform);
		return errorCode;
	    }
#endif /* TCL_THREADS */
	    errorCodeSet = 1;
	    goto cleanup;
	}
    }

    if (HAS(rtPtr->methods, METH_FLUSH)) {
	if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
#if TCL_THREADS
	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
		Tcl_EventuallyFree(rtPtr,
			FreeReflectedTransform);
		return errorCode;
	    }
#endif /* TCL_THREADS */
	    errorCodeSet = 1;
	    goto cleanup;
	}
    }

    /*
     * Are we in the correct thread?
     */







|













|







936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
#if TCL_THREADS
	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
		Tcl_EventuallyFree(rtPtr,
			FreeReflectedTransform);
		return errorCode;
	    }
#endif /* TCL_THREADS */
	    errorCodeSet = true;
	    goto cleanup;
	}
    }

    if (HAS(rtPtr->methods, METH_FLUSH)) {
	if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
#if TCL_THREADS
	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
		Tcl_EventuallyFree(rtPtr,
			FreeReflectedTransform);
		return errorCode;
	    }
#endif /* TCL_THREADS */
	    errorCodeSet = true;
	    goto cleanup;
	}
    }

    /*
     * Are we in the correct thread?
     */
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
    /* TODO: Consider a more appropriate buffer size. */
    bufObj = Tcl_NewByteArrayObj(NULL, toRead);
    Tcl_IncrRefCount(bufObj);
    gotBytes = 0;
    if (rtPtr->eofPending) {
	goto stop;
    }
    rtPtr->readIsDrained = 0;
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data available from
	 * below, possibly EOF).
	 */

	copied = ResultCopy(&rtPtr->result, UCHARP(buf), toRead);







|







1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
    /* TODO: Consider a more appropriate buffer size. */
    bufObj = Tcl_NewByteArrayObj(NULL, toRead);
    Tcl_IncrRefCount(bufObj);
    gotBytes = 0;
    if (rtPtr->eofPending) {
	goto stop;
    }
    rtPtr->readIsDrained = false;
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data available from
	 * below, possibly EOF).
	 */

	copied = ResultCopy(&rtPtr->result, UCHARP(buf), toRead);
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
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
	     */

	    *errorCodePtr = Tcl_GetErrno();
	    goto error;
	}

	if (readBytes == 0) {

	    /*
	     * Zero returned from Tcl_ReadRaw() always indicates EOF
	     * on the down channel.
	     */

	    rtPtr->eofPending = 1;

		/*
		 * Now this is a bit different. The partial data waiting is
		 * converted and returned.
		 */

		if (HAS(rtPtr->methods, METH_DRAIN)) {
		    if (!TransformDrain(rtPtr, errorCodePtr)) {
			goto error;
		    }
		}

		if (ResultLength(&rtPtr->result) == 0) {
		    /*
		     * The drain delivered nothing.
		     */

		    goto stop;
		}

		continue; /* at: while (toRead > 0) */
	} /* readBytes == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */







<





|

|
|
|
|

|
|
|
|
|

|
|
|
|

|
|

|







1159
1160
1161
1162
1163
1164
1165

1166
1167
1168
1169
1170
1171
1172
1173
1174
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
	     */

	    *errorCodePtr = Tcl_GetErrno();
	    goto error;
	}

	if (readBytes == 0) {

	    /*
	     * Zero returned from Tcl_ReadRaw() always indicates EOF
	     * on the down channel.
	     */

	    rtPtr->eofPending = true;

	    /*
	     * Now this is a bit different. The partial data waiting is
	     * converted and returned.
	     */

	    if (HAS(rtPtr->methods, METH_DRAIN)) {
		if (!TransformDrain(rtPtr, errorCodePtr)) {
		    goto error;
		}
	    }

	    if (ResultLength(&rtPtr->result) == 0) {
		/*
		 * The drain delivered nothing.
		 */

		goto stop;
	    }

	    continue; /* at: while (toRead > 0) */
	} /* readBytes == 0 */

	/*
	 * Transform the read chunk, which was not empty. Anything we got back
	 * is a transformation result is put into our buffers, and the next
	 * iteration will put it into the result.
	 */
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
	    Tcl_IncrRefCount(bufObj);
	}
	Tcl_SetByteArrayLength(bufObj, 0);
    } /* while toRead > 0 */

  stop:
    if (gotBytes == 0) {
	rtPtr->eofPending = 0;
    }
    Tcl_DecrRefCount(bufObj);
    Tcl_Release(rtPtr);
    return gotBytes;

  error:
    gotBytes = -1;







|







1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
	    Tcl_IncrRefCount(bufObj);
	}
	Tcl_SetByteArrayLength(bufObj, 0);
    } /* while toRead > 0 */

  stop:
    if (gotBytes == 0) {
	rtPtr->eofPending = false;
    }
    Tcl_DecrRefCount(bufObj);
    Tcl_Release(rtPtr);
    return gotBytes;

  error:
    gotBytes = -1;
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
#endif
    rtPtr->parent = parentChan;
    rtPtr->interp = interp;
    rtPtr->handle = handleObj;
    Tcl_IncrRefCount(handleObj);
    rtPtr->timer = NULL;
    rtPtr->mode = 0;
    rtPtr->readIsDrained = 0;
    rtPtr->eofPending = 0;
    rtPtr->nonblocking =
	    (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING);
    rtPtr->dead = 0;

    /*
     * Query parent for current blocking mode.
     */

    ResultInit(&rtPtr->result);








|
|


|







1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
#endif
    rtPtr->parent = parentChan;
    rtPtr->interp = interp;
    rtPtr->handle = handleObj;
    Tcl_IncrRefCount(handleObj);
    rtPtr->timer = NULL;
    rtPtr->mode = 0;
    rtPtr->readIsDrained = false;
    rtPtr->eofPending = false;
    rtPtr->nonblocking =
	    (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING);
    rtPtr->dead = false;

    /*
     * Query parent for current blocking mode.
     */

    ResultInit(&rtPtr->result);

2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
    rtmPtr = (ReflectedTransformMap *)clientData;
    for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	ReflectedTransform *rtPtr = (ReflectedTransform *)
		Tcl_GetHashValue(hPtr);

	rtPtr->dead = 1;
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&rtmPtr->map);
    Tcl_Free(&rtmPtr->map);

#if TCL_THREADS
    /*







|







2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
    rtmPtr = (ReflectedTransformMap *)clientData;
    for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	ReflectedTransform *rtPtr = (ReflectedTransform *)
		Tcl_GetHashValue(hPtr);

	rtPtr->dead = true;
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&rtmPtr->map);
    Tcl_Free(&rtmPtr->map);

#if TCL_THREADS
    /*
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
	    /*
	     * Ignore entries for other interpreters.
	     */

	    continue;
	}

	rtPtr->dead = 1;
	FreeReflectedTransformArgs(rtPtr);
	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Go through the list of pending results and cancel all whose events were
     * destined for this interpreter. While this is in progress we block any







|







2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
	    /*
	     * Ignore entries for other interpreters.
	     */

	    continue;
	}

	rtPtr->dead = true;
	FreeReflectedTransformArgs(rtPtr);
	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Go through the list of pending results and cancel all whose events were
     * destined for this interpreter. While this is in progress we block any
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293

    ReflectedTransformMap *rtmPtr = GetThreadReflectedTransformMap();
    for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	ReflectedTransform *rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);

	rtPtr->dead = 1;
	FreeReflectedTransformArgs(rtPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_Free(rtmPtr);

    /*
     * Go through the list of pending results and cancel all whose events were







|







2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293

    ReflectedTransformMap *rtmPtr = GetThreadReflectedTransformMap();
    for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
	    hPtr != NULL;
	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
	ReflectedTransform *rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);

	rtPtr->dead = true;
	FreeReflectedTransformArgs(rtPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_Free(rtmPtr);

    /*
     * Go through the list of pending results and cancel all whose events were
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199

	bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec);
	ResultAdd(&rtPtr->result, bytev, bytec);

	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
    }

    rtPtr->readIsDrained = 1;
    return 1;
}

static int
TransformFlush(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,







|







3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199

	bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec);
	ResultAdd(&rtPtr->result, bytev, bytec);

	Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
    }

    rtPtr->readIsDrained = true;
    return 1;
}

static int
TransformFlush(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
#endif /* TCL_THREADS */

    /* ASSERT: rtPtr->method & FLAG(METH_READ) */
    /* ASSERT: rtPtr->mode & TCL_READABLE */

    (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);

    rtPtr->readIsDrained = 0;
    rtPtr->eofPending = 0;
    ResultClear(&rtPtr->result);
}

static int
TransformLimit(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,







|
|







3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
#endif /* TCL_THREADS */

    /* ASSERT: rtPtr->method & FLAG(METH_READ) */
    /* ASSERT: rtPtr->mode & TCL_READABLE */

    (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);

    rtPtr->readIsDrained = false;
    rtPtr->eofPending = false;
    ResultClear(&rtPtr->result);
}

static int
TransformLimit(
    ReflectedTransform *rtPtr,
    int *errorCodePtr,
Changes to generic/tclIOSock.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

#if defined(_WIN32)
/*
 * On Windows, we need to do proper Unicode->UTF-8 conversion.
 */

typedef struct ThreadSpecificData_Sockets {
    int initialized;
    Tcl_DString errorMsg;	/* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#undef gai_strerror
static const char *
gai_strerror(
    int code)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->initialized) {
	Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
    } else {
	Tcl_DStringInit(&tsdPtr->errorMsg);
	tsdPtr->initialized = 1;
    }
    Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
    return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif

/*







|















|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

#if defined(_WIN32)
/*
 * On Windows, we need to do proper Unicode->UTF-8 conversion.
 */

typedef struct ThreadSpecificData_Sockets {
    bool initialized;
    Tcl_DString errorMsg;	/* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#undef gai_strerror
static const char *
gai_strerror(
    int code)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->initialized) {
	Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
    } else {
	Tcl_DStringInit(&tsdPtr->errorMsg);
	tsdPtr->initialized = true;
    }
    Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
    return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif

/*
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
 *----------------------------------------------------------------------
 *
 * TclCreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	1 if the host was valid, 0 if the host could not be converted to an IP
 *	address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */

int

TclCreateSocketAddress(
    Tcl_Interp *interp,		/* Interpreter for querying the desired socket
				 * family */
    struct addrinfo **addrlist,	/* Socket address list */
    const char *host,		/* Host. NULL implies INADDR_ANY */
    int port,			/* Port number */
    int willBind,		/* Is this an address to bind() to or to
				 * connect() to? */
    const char **errorMsgPtr)	/* Place to store the error message detail, if
				 * available. */
{
    char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
    Tcl_DString ds;

    if (host != NULL) {
	if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds,
		NULL) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return 0;
	}
	native = Tcl_DStringValue(&ds);
    }

    /*
     * Workaround for OSX's apparent inability to resolve "localhost", "0"
     * when the loopback device is the only available network interface.







|
|







<
>


















|







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
 *----------------------------------------------------------------------
 *
 * TclCreateSocketAddress --
 *
 *	This function initializes a sockaddr structure for a host and port.
 *
 * Results:
 *	true if the host was valid, false if the host could not be converted
 *	to an IP address.
 *
 * Side effects:
 *	Fills in the *sockaddrPtr structure.
 *
 *----------------------------------------------------------------------
 */


bool
TclCreateSocketAddress(
    Tcl_Interp *interp,		/* Interpreter for querying the desired socket
				 * family */
    struct addrinfo **addrlist,	/* Socket address list */
    const char *host,		/* Host. NULL implies INADDR_ANY */
    int port,			/* Port number */
    int willBind,		/* Is this an address to bind() to or to
				 * connect() to? */
    const char **errorMsgPtr)	/* Place to store the error message detail, if
				 * available. */
{
    char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
    Tcl_DString ds;

    if (host != NULL) {
	if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds,
		NULL) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return false;
	}
	native = Tcl_DStringValue(&ds);
    }

    /*
     * Workaround for OSX's apparent inability to resolve "localhost", "0"
     * when the loopback device is the only available network interface.
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

    if (result != 0) {
	*errorMsgPtr =
#ifdef EAI_SYSTEM	/* Doesn't exist on Windows */
		(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
		gai_strerror(result);
	return 0;
    }

    /*
     * Put IPv4 addresses before IPv6 addresses to maximize backwards
     * compatibility of [fconfigure -sockname] output.
     *
     * There might be more elegant/efficient ways to do this.







|







249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

    if (result != 0) {
	*errorMsgPtr =
#ifdef EAI_SYSTEM	/* Doesn't exist on Windows */
		(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
		gai_strerror(result);
	return false;
    }

    /*
     * Put IPv4 addresses before IPv6 addresses to maximize backwards
     * compatibility of [fconfigure -sockname] output.
     *
     * There might be more elegant/efficient ways to do this.
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
	    v6ptr->ai_next = NULL;
	}
	if (v4head != NULL) {
	    v4ptr->ai_next = *addrlist;
	    *addrlist = v4head;
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *







|







290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
	    v6ptr->ai_next = NULL;
	}
	if (v4head != NULL) {
	    v4ptr->ai_next = *addrlist;
	    *addrlist = v4head;
	}
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenTcpServer --
 *
Changes to generic/tclIOUtil.c.
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
				 * the ned of the list */
} FilesystemRecord;

/*
 */

typedef struct ThreadSpecificData_IOUtilities {
    int initialized;
    size_t cwdPathEpoch;	/* Compared with the global cwdPathEpoch to
				 * determine whether cwdPathPtr is stale. */
    size_t filesystemEpoch;
    Tcl_Obj *cwdPathPtr;	/* A private copy of cwdPathPtr. Updated when
				 * the value is accessed  and cwdPathEpoch has
				 * changed. */
    void *cwdClientData;







|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
				 * the ned of the list */
} FilesystemRecord;

/*
 */

typedef struct ThreadSpecificData_IOUtilities {
    bool initialized;
    size_t cwdPathEpoch;	/* Compared with the global cwdPathEpoch to
				 * determine whether cwdPathPtr is stale. */
    size_t filesystemEpoch;
    Tcl_Obj *cwdPathPtr;	/* A private copy of cwdPathPtr. Updated when
				 * the value is accessed  and cwdPathEpoch has
				 * changed. */
    void *cwdClientData;
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
/* Obsolete */
int
Tcl_Stat(
    const char *path,		/* Pathname of file to stat (in current system
				 * encoding). */
    struct stat *oldStyleBuf)	/* Filled with results of stat call. */
{
    int ret;
    Tcl_StatBuf buf;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSStat(pathPtr, &buf);
    Tcl_DecrRefCount(pathPtr);
    if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
	Tcl_WideInt tmp1, tmp2, tmp3 = 0;

# define OUT_OF_RANGE(x) \
	(((Tcl_WideInt)(x)) < LONG_MIN || ((Tcl_WideInt)(x)) > LONG_MAX)







<




|







239
240
241
242
243
244
245

246
247
248
249
250
251
252
253
254
255
256
257
/* Obsolete */
int
Tcl_Stat(
    const char *path,		/* Pathname of file to stat (in current system
				 * encoding). */
    struct stat *oldStyleBuf)	/* Filled with results of stat call. */
{

    Tcl_StatBuf buf;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    int ret = Tcl_FSStat(pathPtr, &buf);
    Tcl_DecrRefCount(pathPtr);
    if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
	Tcl_WideInt tmp1, tmp2, tmp3 = 0;

# define OUT_OF_RANGE(x) \
	(((Tcl_WideInt)(x)) < LONG_MIN || ((Tcl_WideInt)(x)) > LONG_MAX)
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
/* Obsolete */
int
Tcl_Access(
    const char *path,		/* Pathname of file to access (in current
				 * system encoding). */
    int mode)			/* Permission setting. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSAccess(pathPtr,mode);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. May be
				 * NULL. */
    const char *path,		/* Pathname of file to open. */
    const char *modeString,	/* A list of POSIX open modes or a string such
				 * as "rw". */
    int permissions)		/* The modes to use if creating a new file. */
{
    Tcl_Channel ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
int
Tcl_Chdir(
    const char *dirName)
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSChdir(pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/* Obsolete */
char *
Tcl_GetCwd(







<



|















<



|










<


|







325
326
327
328
329
330
331

332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

351
352
353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372
373
374
/* Obsolete */
int
Tcl_Access(
    const char *path,		/* Pathname of file to access (in current
				 * system encoding). */
    int mode)			/* Permission setting. */
{

    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    int ret = Tcl_FSAccess(pathPtr,mode);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
    Tcl_Interp *interp,		/* Interpreter for error reporting. May be
				 * NULL. */
    const char *path,		/* Pathname of file to open. */
    const char *modeString,	/* A list of POSIX open modes or a string such
				 * as "rw". */
    int permissions)		/* The modes to use if creating a new file. */
{

    Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);

    Tcl_IncrRefCount(pathPtr);
    Tcl_Channel ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);

    return ret;
}

/* Obsolete */
int
Tcl_Chdir(
    const char *dirName)
{

    Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
    Tcl_IncrRefCount(pathPtr);
    int ret = Tcl_FSChdir(pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/* Obsolete */
char *
Tcl_GetCwd(
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
int
Tcl_EvalFile(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the script. */
    const char *fileName)	/* Pathname of the file containing the script.
				 * Performs Tilde-substitution on this
				 * pathaname. */
{
    int ret;
    Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);

    Tcl_IncrRefCount(pathPtr);
    ret = Tcl_FSEvalFile(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/*
 * The basic filesystem implementation.
 */







<



|







389
390
391
392
393
394
395

396
397
398
399
400
401
402
403
404
405
406
int
Tcl_EvalFile(
    Tcl_Interp *interp,		/* Interpreter in which to evaluate the script. */
    const char *fileName)	/* Pathname of the file containing the script.
				 * Performs Tilde-substitution on this
				 * pathaname. */
{

    Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);

    Tcl_IncrRefCount(pathPtr);
    int ret = Tcl_FSEvalFile(interp, pathPtr);
    Tcl_DecrRefCount(pathPtr);
    return ret;
}

/*
 * The basic filesystem implementation.
 */
437
438
439
440
441
442
443
444
445
446
447

448
449
450
451
452
453
454

455
456
457
458
459
460
461
462

463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

487
488
489
490
491
492
493
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr->nextPtr;
	fsRecPtr->fsPtr = NULL;
	Tcl_Free(fsRecPtr);
	fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->filesystemList = NULL;
    tsdPtr->initialized = 0;
}

int

TclFSCwdIsNative(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    /* if not yet initialized - ensure we'll once obtain cwd */
    if (!tsdPtr->cwdPathEpoch) {
	Tcl_Obj *temp = Tcl_FSGetCwd(NULL);

	if (temp) { Tcl_DecrRefCount(temp); }
    }

    if (tsdPtr->cwdClientData != NULL) {
	return 1;
    } else {
	return 0;
    }

}

/*
 *----------------------------------------------------------------------
 *
 * TclFSCwdPointerEquals --
 *	Determine whether the given pathname is equal to the current working
 *	directory.
 *
 * Results:
 *	1 if equal, 0 otherwise.
 *
 * Side effects:
 *	Updates TSD if needed.
 *
 *	Stores a pointer to the current directory in *pathPtrPtr if it is not
 *	already there and the current directory is not NULL.
 *
 *	If *pathPtrPtr is not null its reference count is decremented
 *	before it is replaced.
 *----------------------------------------------------------------------
 */

int

TclFSCwdPointerEquals(
    Tcl_Obj **pathPtrPtr)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    Tcl_MutexLock(&cwdMutex);
    if (tsdPtr->cwdPathPtr == NULL







|


<
>







>
|
|
|
<
<
<
<
|
>










|












<
>







432
433
434
435
436
437
438
439
440
441

442
443
444
445
446
447
448
449
450
451
452
453




454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478

479
480
481
482
483
484
485
486
    while (fsRecPtr != NULL) {
	tmpFsRecPtr = fsRecPtr->nextPtr;
	fsRecPtr->fsPtr = NULL;
	Tcl_Free(fsRecPtr);
	fsRecPtr = tmpFsRecPtr;
    }
    tsdPtr->filesystemList = NULL;
    tsdPtr->initialized = false;
}


bool
TclFSCwdIsNative(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    /* if not yet initialized - ensure we'll once obtain cwd */
    if (!tsdPtr->cwdPathEpoch) {
	Tcl_Obj *temp = Tcl_FSGetCwd(NULL);
	if (temp) {
	    Tcl_DecrRefCount(temp);
	}
    }





    return (tsdPtr->cwdClientData != NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFSCwdPointerEquals --
 *	Determine whether the given pathname is equal to the current working
 *	directory.
 *
 * Results:
 *	true if equal, false otherwise.
 *
 * Side effects:
 *	Updates TSD if needed.
 *
 *	Stores a pointer to the current directory in *pathPtrPtr if it is not
 *	already there and the current directory is not NULL.
 *
 *	If *pathPtrPtr is not null its reference count is decremented
 *	before it is replaced.
 *----------------------------------------------------------------------
 */


bool
TclFSCwdPointerEquals(
    Tcl_Obj **pathPtrPtr)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);

    Tcl_MutexLock(&cwdMutex);
    if (tsdPtr->cwdPathPtr == NULL
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526

527
528
529
530
531
532

533



534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
	}
	tsdPtr->cwdPathEpoch = cwdPathEpoch;
    }
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
	tsdPtr->initialized = 1;
    }

    if (pathPtrPtr == NULL) {
	return (tsdPtr->cwdPathPtr == NULL);
    }

    if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
	return 1;

    } else {
	Tcl_Size len1, len2;
	const char *str1, *str2;

	str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
	str2 = TclGetStringFromObj(*pathPtrPtr, &len2);

	if ((len1 == len2) && !memcmp(str1, str2, len1)) {



	    /*
	     * The values are equal but the objects are different.  Cache the
	     * current structure in place of the old one.
	     */

	    Tcl_DecrRefCount(*pathPtrPtr);
	    *pathPtrPtr = tsdPtr->cwdPathPtr;
	    Tcl_IncrRefCount(*pathPtrPtr);
	    return 1;
	} else {
	    return 0;
	}
    }
}

static void
FsRecacheFilesystemList(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
    FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list;







|







|
>
|
|
<
<
|
|
>
|
>
>
>
|
|
|
|

|
|
|
|
<
<
<
<







504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522


523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538




539
540
541
542
543
544
545
	}
	tsdPtr->cwdPathEpoch = cwdPathEpoch;
    }
    Tcl_MutexUnlock(&cwdMutex);

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
	tsdPtr->initialized = true;
    }

    if (pathPtrPtr == NULL) {
	return (tsdPtr->cwdPathPtr == NULL);
    }

    if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
	return true;
    }

    Tcl_Size len1, len2;


    const char *str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
    const char *str2 = TclGetStringFromObj(*pathPtrPtr, &len2);

    if ((len1 != len2) || memcmp(str1, str2, len1)) {
	return false;
    }

    /*
     * The values are equal but the objects are different.  Cache the
     * current structure in place of the old one.
     */

    Tcl_DecrRefCount(*pathPtrPtr);
    *pathPtrPtr = tsdPtr->cwdPathPtr;
    Tcl_IncrRefCount(*pathPtrPtr);
    return true;




}

static void
FsRecacheFilesystemList(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
    FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL, *toFree = NULL, *list;
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617

    /*
     * Make sure the above gets released on thread exit.
     */

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
	tsdPtr->initialized = 1;
    }
}

static FilesystemRecord *
FsGetFirstFilesystem(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);







|







595
596
597
598
599
600
601
602
603
604
605
606
607
608
609

    /*
     * Make sure the above gets released on thread exit.
     */

    if (tsdPtr->initialized == 0) {
	Tcl_CreateThreadExitHandler(FsThrExitProc, tsdPtr);
	tsdPtr->initialized = true;
    }
}

static FilesystemRecord *
FsGetFirstFilesystem(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
847
848
849
850
851
852
853
854
855
856
857
858
859

860
861
862
863
864
865
866
867
 */

int
Tcl_FSRegister(
    void *clientData,		/* Client-specific data for this filesystem. */
    const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
    FilesystemRecord *newFilesystemPtr;

    if (fsPtr == NULL) {
	return TCL_ERROR;
    }


    newFilesystemPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord));

    newFilesystemPtr->clientData = clientData;
    newFilesystemPtr->fsPtr = fsPtr;

    Tcl_MutexLock(&filesystemMutex);

    newFilesystemPtr->nextPtr = filesystemList;







<
<




>
|







839
840
841
842
843
844
845


846
847
848
849
850
851
852
853
854
855
856
857
858
 */

int
Tcl_FSRegister(
    void *clientData,		/* Client-specific data for this filesystem. */
    const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{


    if (fsPtr == NULL) {
	return TCL_ERROR;
    }

    FilesystemRecord *newFilesystemPtr = (FilesystemRecord *)
	    Tcl_Alloc(sizeof(FilesystemRecord));

    newFilesystemPtr->clientData = clientData;
    newFilesystemPtr->fsPtr = fsPtr;

    Tcl_MutexLock(&filesystemMutex);

    newFilesystemPtr->nextPtr = filesystemList;
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
 */

int
Tcl_FSUnregister(
    const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
    int retVal = TCL_ERROR;
    FilesystemRecord *fsRecPtr;

    Tcl_MutexLock(&filesystemMutex);

    /*
     * Traverse filesystemList in search of the record whose
     * 'fsPtr' member matches 'fsPtr' and remove that record from the list.
     * Do not revmoe the record for the native filesystem.
     */

    fsRecPtr = filesystemList;
    while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    if (fsRecPtr->prevPtr) {
		fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
	    } else {
		filesystemList = fsRecPtr->nextPtr;
	    }







<









|







898
899
900
901
902
903
904

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
 */

int
Tcl_FSUnregister(
    const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
    int retVal = TCL_ERROR;


    Tcl_MutexLock(&filesystemMutex);

    /*
     * Traverse filesystemList in search of the record whose
     * 'fsPtr' member matches 'fsPtr' and remove that record from the list.
     * Do not revmoe the record for the native filesystem.
     */

    FilesystemRecord *fsRecPtr = filesystemList;
    while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
	if (fsRecPtr->fsPtr == fsPtr) {
	    if (fsRecPtr->prevPtr) {
		fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
	    } else {
		filesystemList = fsRecPtr->nextPtr;
	    }
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
	goto endOfMounts;
    }
    if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (Tcl_Size i=0 ; i<mLength ; i++) {
	Tcl_Obj *mElt;
	int found = 0;

	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (Tcl_Size j=0 ; j<gLength ; j++) {
	    Tcl_Obj *gElt;

	    Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
	    if (Tcl_FSEqualPaths(mElt, gElt)) {
		found = 1;
		if (!dir) {
		    /*
		     * We don't want to list this.
		     */

		    Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
		    gLength--;







|








|







1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
	goto endOfMounts;
    }
    if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
	goto endOfMounts;
    }
    for (Tcl_Size i=0 ; i<mLength ; i++) {
	Tcl_Obj *mElt;
	bool found = false;

	Tcl_ListObjIndex(NULL, mounts, i, &mElt);

	for (Tcl_Size j=0 ; j<gLength ; j++) {
	    Tcl_Obj *gElt;

	    Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
	    if (Tcl_FSEqualPaths(mElt, gElt)) {
		found = true;
		if (!dir) {
		    /*
		     * We don't want to list this.
		     */

		    Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
		    gLength--;
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
    int startAt)		/* Offset the string of pathPtr to start at.
				 * Must either be 0 or offset of a directory
				 * separator at the end of a pathname part that
				 * is already normalized, i.e. not the index of
				 * the byte just after the separator. */
{
    Tcl_Size i;
    int isVfsPath = 0;
    const char *path;

    /*
     * Pathnames starting with a UNC prefix and ending with a colon character
     * are reserved for VFS use.  These names can not conflict with real UNC
     * pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
     * rfc3986's definition of reg-name.







|







1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
    int startAt)		/* Offset the string of pathPtr to start at.
				 * Must either be 0 or offset of a directory
				 * separator at the end of a pathname part that
				 * is already normalized, i.e. not the index of
				 * the byte just after the separator. */
{
    Tcl_Size i;
    bool isVfsPath = false;
    const char *path;

    /*
     * Pathnames starting with a UNC prefix and ending with a colon character
     * are reserved for VFS use.  These names can not conflict with real UNC
     * pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
     * rfc3986's definition of reg-name.
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
	    }
	    if (path[i] == path[0]) {
		break;
	    }
	}
	--i;
	if (path[i] == ':') {
	    isVfsPath = 1;
	}
    }

    /*
     * Call the the normalizePathProc routine of each registered filesystem.
     */
    FilesystemRecord *firstFsRecPtr = FsGetFirstFilesystem();







|







1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
	    }
	    if (path[i] == path[0]) {
		break;
	    }
	}
	--i;
	if (path[i] == ':') {
	    isVfsPath = true;
	}
    }

    /*
     * Call the the normalizePathProc routine of each registered filesystem.
     */
    FilesystemRecord *firstFsRecPtr = FsGetFirstFilesystem();
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
int
TclGetOpenMode(
    Tcl_Interp *interp,		/* Interpreter, possibly NULL, to use for
				 * error reporting. */
    const char *modeString,	/* Mode string, e.g. "r+" or "RDONLY CREAT" */
    int *modeFlagsPtr)
{
    int mode, c, gotRW;
    Tcl_Size modeArgc;
    const char **modeArgv = NULL, *flag;

    /*
     * Check for the simpler fopen-like access modes like "r" which are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.







|







1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
int
TclGetOpenMode(
    Tcl_Interp *interp,		/* Interpreter, possibly NULL, to use for
				 * error reporting. */
    const char *modeString,	/* Mode string, e.g. "r+" or "RDONLY CREAT" */
    int *modeFlagsPtr)
{
    int mode, c;
    Tcl_Size modeArgc;
    const char **modeArgv = NULL, *flag;

    /*
     * Check for the simpler fopen-like access modes like "r" which are
     * distinguished from the POSIX access modes by the presence of a
     * lower-case first letter.
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
	}
	if (modeArgv) {
	    Tcl_Free((void *)modeArgv);
	}
	return -1;
    }

    gotRW = 0;
    for (Tcl_Size i = 0; i < modeArgc; i++) {
	flag = modeArgv[i];
	c = flag[0];
	if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
	    if (gotRW) {
	    invRW:
		if (interp != NULL) {
		    TclPrintfResult(interp,
			    "invalid access mode \"%s\": modes RDONLY, "
			    "RDWR, and WRONLY cannot be combined", flag);
		}
		goto invAccessMode;
	    }
	    mode = (mode & ~O_ACCMODE) | O_RDONLY;
	    gotRW = 1;
	} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
	    if (gotRW) {
		goto invRW;
	    }
	    mode = (mode & ~O_ACCMODE) | O_WRONLY;
	    gotRW = 1;
	} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
	    if (gotRW) {
		goto invRW;
	    }
	    mode = (mode & ~O_ACCMODE) | O_RDWR;
	    gotRW = 1;
	} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
	    if (mode & O_APPEND) {
	    accessFlagRepeated:
		if (interp) {
		    TclPrintfResult(interp, "access mode \"%s\" repeated",
			    flag);
		}







|














|





|





|







1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
	}
	if (modeArgv) {
	    Tcl_Free((void *)modeArgv);
	}
	return -1;
    }

    bool gotRW = false;
    for (Tcl_Size i = 0; i < modeArgc; i++) {
	flag = modeArgv[i];
	c = flag[0];
	if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
	    if (gotRW) {
	    invRW:
		if (interp != NULL) {
		    TclPrintfResult(interp,
			    "invalid access mode \"%s\": modes RDONLY, "
			    "RDWR, and WRONLY cannot be combined", flag);
		}
		goto invAccessMode;
	    }
	    mode = (mode & ~O_ACCMODE) | O_RDONLY;
	    gotRW = true;
	} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
	    if (gotRW) {
		goto invRW;
	    }
	    mode = (mode & ~O_ACCMODE) | O_WRONLY;
	    gotRW = true;
	} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
	    if (gotRW) {
		goto invRW;
	    }
	    mode = (mode & ~O_ACCMODE) | O_RDWR;
	    gotRW = true;
	} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
	    if (mode & O_APPEND) {
	    accessFlagRepeated:
		if (interp) {
		    TclPrintfResult(interp, "access mode \"%s\" repeated",
			    flag);
		}
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
#ifdef _WIN32
#define getenv(x) _wgetenv(L##x)
#define atoi(x) _wtoi(x)
#else
#define WCHAR char
#endif

static int
SkipUnlink(
    Tcl_Obj *shlibFile)
{
    /*
     * Unlinking is not performed in the following cases:
     *
     * 1. The operating system is HPUX.
     *
     * 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
     *    set to true (an integer > 0)
     *
     * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS
     *    filesystem can be detected (using statfs, if available).
     */

#ifdef hpux
    (void)shlibFile;
    return 1;
#else
    WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");

    if (skipstr && (skipstr[0] != '\0')) {
	return atoi(skipstr);
    }

#ifndef TCL_TEMPLOAD_NO_UNLINK
    (void)shlibFile;
#else

/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether
 * this automatic overriding of unlink is included.
 */
#ifndef NO_FSTATFS
    {

	struct statfs fs;
	/*
	 * Have fstatfs. May not have the AUFS super magic ... Indeed our build
	 * box is too old to have it directly in the headers. Define taken from
	 *     http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
	 *     http://aufs.sourceforge.net/
	 * Better reference will be gladly accepted.
	 */
#ifndef AUFS_SUPER_MAGIC

/* AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for
 * testing if a newer AUFS does not have the bug any more.
*/


#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */

	if ((statfs(TclGetString(shlibFile), &fs) == 0)
		&& (fs.f_type == AUFS_SUPER_MAGIC)) {
	    return 1;
	}
    }
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */

    /*
     * No HPUX, environment variable override, or AUFS detected.  Perform
     * unlink.
     */
    return 0;
#endif /* hpux */
}

int
Tcl_LoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Pathname of the file containing the dynamic







|

















|










>
|
|
|
<
|
>
|
|
|
|
|
|
|
<
<
>
|
|
|
>
>


>
|
|
|
<








|







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
#ifdef _WIN32
#define getenv(x) _wgetenv(L##x)
#define atoi(x) _wtoi(x)
#else
#define WCHAR char
#endif

static bool
SkipUnlink(
    Tcl_Obj *shlibFile)
{
    /*
     * Unlinking is not performed in the following cases:
     *
     * 1. The operating system is HPUX.
     *
     * 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
     *    set to true (an integer > 0)
     *
     * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS
     *    filesystem can be detected (using statfs, if available).
     */

#ifdef hpux
    (void)shlibFile;
    return true;
#else
    WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");

    if (skipstr && (skipstr[0] != '\0')) {
	return atoi(skipstr);
    }

#ifndef TCL_TEMPLOAD_NO_UNLINK
    (void)shlibFile;
#else
    /*
     * At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control
     * whether this automatic overriding of unlink is included.
      */


#ifndef NO_FSTATFS
    struct statfs fs;
    /*
     * Have fstatfs. May not have the AUFS super magic ... Indeed our build
     * box is too old to have it directly in the headers. Define taken from
     *     http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
     *     http://aufs.sourceforge.net/
     * Better reference will be gladly accepted.


     *
     * AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for
     * testing if a newer AUFS does not have the bug any more.
     */

#ifndef AUFS_SUPER_MAGIC
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */

    if ((statfs(TclGetString(shlibFile), &fs) == 0)
	    && (fs.f_type == AUFS_SUPER_MAGIC)) {
	return true;

    }
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */

    /*
     * No HPUX, environment variable override, or AUFS detected.  Perform
     * unlink.
     */
    return false;
#endif /* hpux */
}

int
Tcl_LoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Pathname of the file containing the dynamic
Changes to generic/tclIcu.c.
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
/*
 * Detect the likely encoding of the string encoded in the given byte array.
 */
static int
DetectEncoding(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    int all)
{
    // Confirm we have the profile of functions we need.
    if (ucsdet_open == NULL ||
	    ucsdet_setText == NULL ||
	    ucsdet_detect == NULL ||
	    ucsdet_detectAll == NULL ||
	    ucsdet_getName == NULL ||







|







297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
/*
 * Detect the likely encoding of the string encoded in the given byte array.
 */
static int
DetectEncoding(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    bool all)
{
    // Confirm we have the profile of functions we need.
    if (ucsdet_open == NULL ||
	    ucsdet_setText == NULL ||
	    ucsdet_detect == NULL ||
	    ucsdet_detectAll == NULL ||
	    ucsdet_getName == NULL ||
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
 *
 *------------------------------------------------------------------------
 */
static int
IcuObjToUCharDString(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    int strict,
    Tcl_DString *dsPtr)
{
    Tcl_Encoding encoding;

    /*
     * TODO - not the most efficient to get an encoding every time.
     * However, we cannot use Tcl_UtfToChar16DString as that blithely
     * ignores invalid or ill-formed UTF8 strings.
     */
    encoding = Tcl_GetEncoding(interp, "utf-16");
    if (encoding == NULL) {
	return TCL_ERROR;
    }

    int result;
    char *s;
    Tcl_Size len;
    s = Tcl_GetStringFromObj(objPtr, &len);
    result = Tcl_UtfToExternalDStringEx(interp, encoding, s, len,
	    strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE,
	    dsPtr, NULL);
    if (result != TCL_OK) {
	Tcl_DStringFree(dsPtr); /* Must be done on error */
	/* TCL_CONVER_* errors -> TCL_ERROR */
	result = TCL_ERROR;
    }







|


<
<





|




<
<

|
|







441
442
443
444
445
446
447
448
449
450


451
452
453
454
455
456
457
458
459
460


461
462
463
464
465
466
467
468
469
470
 *
 *------------------------------------------------------------------------
 */
static int
IcuObjToUCharDString(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr,
    bool strict,
    Tcl_DString *dsPtr)
{


    /*
     * TODO - not the most efficient to get an encoding every time.
     * However, we cannot use Tcl_UtfToChar16DString as that blithely
     * ignores invalid or ill-formed UTF8 strings.
     */
    Tcl_Encoding encoding = Tcl_GetEncoding(interp, "utf-16");
    if (encoding == NULL) {
	return TCL_ERROR;
    }



    Tcl_Size len;
    char *s = Tcl_GetStringFromObj(objPtr, &len);
    int result = Tcl_UtfToExternalDStringEx(interp, encoding, s, len,
	    strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE,
	    dsPtr, NULL);
    if (result != TCL_OK) {
	Tcl_DStringFree(dsPtr); /* Must be done on error */
	/* TCL_CONVER_* errors -> TCL_ERROR */
	result = TCL_ERROR;
    }
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
 *
 *------------------------------------------------------------------------
 */
static Tcl_Obj *
IcuObjFromUCharDString(
    Tcl_Interp *interp,
    Tcl_DString *dsPtr,
    int strict)
{
    Tcl_Encoding encoding;

    /*
     * TODO - not the most efficient to get an encoding every time.
     * However, we cannot use Tcl_UtfToChar16DString as that blithely
     * ignores invalid or ill-formed UTF8 strings.
     */
    encoding = Tcl_GetEncoding(interp, "utf-16");
    if (encoding == NULL) {
	return NULL;
    }
    Tcl_Obj *objPtr = NULL;
    char *s = Tcl_DStringValue(dsPtr);
    Tcl_Size len = Tcl_DStringLength(dsPtr);
    Tcl_DString dsOut;
    int result;
    result  = Tcl_ExternalToUtfDStringEx(interp, encoding, s, len,
	    strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE,
	    &dsOut, NULL);

    if (result == TCL_OK) {
	objPtr = Tcl_DStringToObj(&dsOut); /* Clears dsPtr! */
    }








|

<
<





|







<
|







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
513
514
515
516
517
 *
 *------------------------------------------------------------------------
 */
static Tcl_Obj *
IcuObjFromUCharDString(
    Tcl_Interp *interp,
    Tcl_DString *dsPtr,
    bool strict)
{


    /*
     * TODO - not the most efficient to get an encoding every time.
     * However, we cannot use Tcl_UtfToChar16DString as that blithely
     * ignores invalid or ill-formed UTF8 strings.
     */
    Tcl_Encoding encoding = Tcl_GetEncoding(interp, "utf-16");
    if (encoding == NULL) {
	return NULL;
    }
    Tcl_Obj *objPtr = NULL;
    char *s = Tcl_DStringValue(dsPtr);
    Tcl_Size len = Tcl_DStringLength(dsPtr);
    Tcl_DString dsOut;

    int result = Tcl_ExternalToUtfDStringEx(interp, encoding, s, len,
	    strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE,
	    &dsOut, NULL);

    if (result == TCL_OK) {
	objPtr = Tcl_DStringToObj(&dsOut); /* Clears dsPtr! */
    }

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
	return TCL_ERROR;
    }

    if (objc == 1) {
	return DetectableEncodings(interp);
    }

    int all = 0;
    if (objc == 3) {
	if (strcmp("-all", Tcl_GetString(objv[2]))) {
	    TclPrintfResult(interp, "Invalid option %s, must be \"-all\"",
		    Tcl_GetString(objv[2]));
	    return TCL_ERROR;
	}
	all = 1;
    }

    return DetectEncoding(interp, objv[1], all);
}

/*
 *------------------------------------------------------------------------







|






|







549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
	return TCL_ERROR;
    }

    if (objc == 1) {
	return DetectableEncodings(interp);
    }

    bool all = false;
    if (objc == 3) {
	if (strcmp("-all", Tcl_GetString(objv[2]))) {
	    TclPrintfResult(interp, "Invalid option %s, must be \"-all\"",
		    Tcl_GetString(objv[2]));
	    return TCL_ERROR;
	}
	all = true;
    }

    return DetectEncoding(interp, objv[1], all);
}

/*
 *------------------------------------------------------------------------
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
 *------------------------------------------------------------------------
 */
static int
IcuConverttoDString(
    Tcl_Interp *interp,
    Tcl_DString *dsInPtr,	/* Input UTF16 */
    const char *icuEncName,
    int strict,
    Tcl_DString *dsOutPtr)	/* Output encoded string. */
{
    if (ucnv_open == NULL || ucnv_close == NULL ||
	ucnv_fromUChars == NULL || UCNV_FROM_U_CALLBACK_STOP == NULL) {
	return FunctionNotAvailableError(interp);
    }








|







689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
 *------------------------------------------------------------------------
 */
static int
IcuConverttoDString(
    Tcl_Interp *interp,
    Tcl_DString *dsInPtr,	/* Input UTF16 */
    const char *icuEncName,
    bool strict,
    Tcl_DString *dsOutPtr)	/* Output encoded string. */
{
    if (ucnv_open == NULL || ucnv_close == NULL ||
	ucnv_fromUChars == NULL || UCNV_FROM_U_CALLBACK_STOP == NULL) {
	return FunctionNotAvailableError(interp);
    }

776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
 */
static int
IcuBytesToUCharDString(
    Tcl_Interp *interp,
    const unsigned char *bytes,
    Tcl_Size nbytes,
    const char *icuEncName,
    int strict,
    Tcl_DString *dsOutPtr)	/* Output UChar string. */
{
    if (ucnv_open == NULL || ucnv_close == NULL ||
	ucnv_toUChars == NULL || UCNV_TO_U_CALLBACK_STOP == NULL) {
	return FunctionNotAvailableError(interp);
    }








|







769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
 */
static int
IcuBytesToUCharDString(
    Tcl_Interp *interp,
    const unsigned char *bytes,
    Tcl_Size nbytes,
    const char *icuEncName,
    bool strict,
    Tcl_DString *dsOutPtr)	/* Output UChar string. */
{
    if (ucnv_open == NULL || ucnv_close == NULL ||
	ucnv_toUChars == NULL || UCNV_TO_U_CALLBACK_STOP == NULL) {
	return FunctionNotAvailableError(interp);
    }

934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
/*
 * Common function for parsing convert options.
 */
static int IcuParseConvertOptions(
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[],
    int *strictPtr,
    Tcl_Obj **failindexVarPtr)
{
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ICUENCNAME STRING");
	return TCL_ERROR;
    }
    objc -= 2; /* truncate fixed arguments */

    /* Use GetIndexFromObj for option parsing so -failindex can be added later */

    static const char *optNames[] = {"-profile", "-failindex", NULL};
    enum { OPT_PROFILE, OPT_FAILINDEX } opt;
    int strict = 1;
    for (int i = 1; i < objc; ++i) {
	if (Tcl_GetIndexFromObj(
		interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
	    return TCL_ERROR;
	}
	++i;
	if (i == objc) {
	    TclPrintfResult(interp, "Missing value for option %s.",
		    Tcl_GetString(objv[i - 1]));
	    return TCL_ERROR;
	}
	const char *s = Tcl_GetString(objv[i]);
	switch (opt) {
	case OPT_PROFILE:
	    if (!strcmp(s, "replace")) {
		strict = 0;
	    } else if (strcmp(s, "strict")) {
		TclPrintfResult(interp,
			"Invalid value \"%s\" supplied for option"
			" \"-profile\". Must be \"strict\" or \"replace\".",
			s);
		return TCL_ERROR;
	    }







|












|















|







927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
/*
 * Common function for parsing convert options.
 */
static int IcuParseConvertOptions(
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[],
    bool *strictPtr,
    Tcl_Obj **failindexVarPtr)
{
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ICUENCNAME STRING");
	return TCL_ERROR;
    }
    objc -= 2; /* truncate fixed arguments */

    /* Use GetIndexFromObj for option parsing so -failindex can be added later */

    static const char *optNames[] = {"-profile", "-failindex", NULL};
    enum { OPT_PROFILE, OPT_FAILINDEX } opt;
    bool strict = true;
    for (int i = 1; i < objc; ++i) {
	if (Tcl_GetIndexFromObj(
		interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
	    return TCL_ERROR;
	}
	++i;
	if (i == objc) {
	    TclPrintfResult(interp, "Missing value for option %s.",
		    Tcl_GetString(objv[i - 1]));
	    return TCL_ERROR;
	}
	const char *s = Tcl_GetString(objv[i]);
	switch (opt) {
	case OPT_PROFILE:
	    if (!strcmp(s, "replace")) {
		strict = false;
	    } else if (strcmp(s, "strict")) {
		TclPrintfResult(interp,
			"Invalid value \"%s\" supplied for option"
			" \"-profile\". Must be \"strict\" or \"replace\".",
			s);
		return TCL_ERROR;
	    }
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
static int
IcuConvertfromObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int strict;
    Tcl_Obj *failindexVar;

    if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_Size nbytes;







|







1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
static int
IcuConvertfromObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    bool strict;
    Tcl_Obj *failindexVar;

    if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_Size nbytes;
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
static int
IcuConverttoObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int strict;
    Tcl_Obj *failindexVar;

    if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_DString dsIn;







|







1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
static int
IcuConverttoObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    bool strict;
    Tcl_Obj *failindexVar;

    if (IcuParseConvertOptions(interp, objc, objv, &strict, &failindexVar) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_DString dsIn;
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
1139
1140
1141
1142
1143
1144
    enum { OPT_PROFILE, OPT_MODE } opt;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ?-mode MODE? STRING");
	return TCL_ERROR;
    }

    int strict = 1;
    NormalizationMode mode = MODE_NFC;
    for (int i = 1; i < objc - 1; ++i) {
	if (Tcl_GetIndexFromObj(
		interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
	    return TCL_ERROR;
	}
	++i;
	if (i == (objc-1)) {
	    TclPrintfResult(interp, "Missing value for option %s.",
		    Tcl_GetString(objv[i - 1]));
	    return TCL_ERROR;
	}
	const char *s = Tcl_GetString(objv[i]);
	switch (opt) {
	case OPT_PROFILE:
	    if (!strcmp(s, "replace")) {
		strict = 0;
	    } else if (strcmp(s, "strict")) {
		TclPrintfResult(interp,
			"Invalid value \"%s\" supplied for option \"-profile\". "
			"Must be \"strict\" or \"replace\".",
			s);
		return TCL_ERROR;
	    }







|
















|







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
    enum { OPT_PROFILE, OPT_MODE } opt;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-profile PROFILE? ?-mode MODE? STRING");
	return TCL_ERROR;
    }

    bool strict = true;
    NormalizationMode mode = MODE_NFC;
    for (int i = 1; i < objc - 1; ++i) {
	if (Tcl_GetIndexFromObj(
		interp, objv[i], optNames, "option", 0, &opt) != TCL_OK) {
	    return TCL_ERROR;
	}
	++i;
	if (i == (objc-1)) {
	    TclPrintfResult(interp, "Missing value for option %s.",
		    Tcl_GetString(objv[i - 1]));
	    return TCL_ERROR;
	}
	const char *s = Tcl_GetString(objv[i]);
	switch (opt) {
	case OPT_PROFILE:
	    if (!strcmp(s, "replace")) {
		strict = false;
	    } else if (strcmp(s, "strict")) {
		TclPrintfResult(interp,
			"Invalid value \"%s\" supplied for option \"-profile\". "
			"Must be \"strict\" or \"replace\".",
			s);
		return TCL_ERROR;
	    }
Changes to generic/tclInt.h.
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */
    CommandTrace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    int reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveCommandTrace;

/*
 * When a variable trace is active (i.e. its associated procedure is
 * executing) one of the following structures is linked into a list associated
 * with the variable's interpreter. The information in the structure is needed







|







608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */
    CommandTrace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    bool reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveCommandTrace;

/*
 * When a variable trace is active (i.e. its associated procedure is
 * executing) one of the following structures is linked into a list associated
 * with the variable's interpreter. The information in the structure is needed
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	}\
    }

/*
 * Macros to read various flag bits of variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE int	TclIsVarScalar(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarConstant(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarLink(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArray(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarUndefined(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArrayElement(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarTemporary(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarArgument(Var *varPtr);
 * MODULE_SCOPE int	TclIsVarResolved(Var *varPtr);
 */

#define TclVarFindHiddenArray(varPtr,arrayPtr)				\
    do {								\
	if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) &&		\
		(TclVarParentArray(varPtr) != NULL)) {			\
	    arrayPtr = TclVarParentArray(varPtr);			\







|
|
|
|
|
|
|
|
|







849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	}\
    }

/*
 * Macros to read various flag bits of variables.
 * The ANSI C "prototypes" for these macros are:
 *
 * MODULE_SCOPE bool	TclIsVarScalar(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarConstant(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarLink(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarArray(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarUndefined(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarArrayElement(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarTemporary(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarArgument(Var *varPtr);
 * MODULE_SCOPE bool	TclIsVarResolved(Var *varPtr);
 */

#define TclVarFindHiddenArray(varPtr,arrayPtr)				\
    do {								\
	if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) &&		\
		(TclVarParentArray(varPtr) != NULL)) {			\
	    arrayPtr = TclVarParentArray(varPtr);			\
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
    struct ActiveInterpTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */
    Trace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    int reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveInterpTrace;

/*
 * Flag values designating types of execution traces. See tclTrace.c for
 * related flag values.
 *







|







1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
    struct ActiveInterpTrace *nextPtr;
				/* Next in list of all active command traces
				 * for the interpreter, or NULL if no more. */
    Trace *nextTracePtr;	/* Next trace to check after current trace
				 * procedure returns; if this trace gets
				 * deleted, must update pointer to avoid using
				 * free'd memory. */
    bool reverseScan;		/* Boolean set true when traces are scanning
				 * in reverse order. */
} ActiveInterpTrace;

/*
 * Flag values designating types of execution traces. See tclTrace.c for
 * related flag values.
 *
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
				 * stack on the heap. */
    Tcl_Obj *constants[2];	/* Pointers to constant "0" and "1" objs. */
    struct Tcl_Interp *interp;	/* Owning interpreter. */
    struct NRE_callback *callbackPtr;
				/* Top callback in NRE's stack. */
    struct CoroutineData *corPtr;
				/* Current coroutine. */
    int rewind;			/* Set when exception trapping is disabled
				 * because a context is being deleted (e.g.,
				 * the current coroutine has been deleted). */
} ExecEnv;

#define COR_IS_SUSPENDED(corPtr) \
    ((corPtr)->stackLevel == NULL)








|







1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
				 * stack on the heap. */
    Tcl_Obj *constants[2];	/* Pointers to constant "0" and "1" objs. */
    struct Tcl_Interp *interp;	/* Owning interpreter. */
    struct NRE_callback *callbackPtr;
				/* Top callback in NRE's stack. */
    struct CoroutineData *corPtr;
				/* Current coroutine. */
    bool rewind;		/* Set when exception trapping is disabled
				 * because a context is being deleted (e.g.,
				 * the current coroutine has been deleted). */
} ExecEnv;

#define COR_IS_SUSPENDED(corPtr) \
    ((corPtr)->stackLevel == NULL)

2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;	/* Allocator cache for stack frames. */
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
				 * structs for this interp's thread; see
				 * tclObj.c and tclThreadAlloc.c */
    int *asyncReadyPtr;		/* Pointer to the asyncReady indicator for
				 * this interp's thread; see tclAsync.c */
    /*
     * The pointer to the object system root ekeko. c.f. TIP #257.
     */
    void *objectFoundation;	/* Pointer to the Foundation structure of the
				 * object system, which contains things like
				 * references to key namespaces. See







|







2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
     * They are used by the macros defined below.
     */

    AllocCache *allocCache;	/* Allocator cache for stack frames. */
    void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
				 * structs for this interp's thread; see
				 * tclObj.c and tclThreadAlloc.c */
    bool *asyncReadyPtr;	/* Pointer to the asyncReady indicator for
				 * this interp's thread; see tclAsync.c */
    /*
     * The pointer to the object system root ekeko. c.f. TIP #257.
     */
    void *objectFoundation;	/* Pointer to the Foundation structure of the
				 * object system, which contains things like
				 * references to key namespaces. See
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
     * TIP #348 IMPLEMENTATION  -  Substituted error stack
     */
    Tcl_Obj *errorStack;	/* [info errorstack] value (as a Tcl_Obj). */
    Tcl_Obj *upLiteral;		/* "UP" literal for [info errorstack] */
    Tcl_Obj *callLiteral;	/* "CALL" literal for [info errorstack] */
    Tcl_Obj *innerLiteral;	/* "INNER" literal for [info errorstack] */
    Tcl_Obj *innerContext;	/* cached list for fast reallocation */
    int resetErrorStack;	/* controls cleaning up of ::errorStack */

#ifdef TCL_COMPILE_STATS
    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation. This should be the last field of Interp.
     */








|







2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
     * TIP #348 IMPLEMENTATION  -  Substituted error stack
     */
    Tcl_Obj *errorStack;	/* [info errorstack] value (as a Tcl_Obj). */
    Tcl_Obj *upLiteral;		/* "UP" literal for [info errorstack] */
    Tcl_Obj *callLiteral;	/* "CALL" literal for [info errorstack] */
    Tcl_Obj *innerLiteral;	/* "INNER" literal for [info errorstack] */
    Tcl_Obj *innerContext;	/* cached list for fast reallocation */
    bool resetErrorStack;	/* controls cleaning up of ::errorStack */

#ifdef TCL_COMPILE_STATS
    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation. This should be the last field of Interp.
     */

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
3343
3344
3345
			    Tcl_Obj *objv[], Tcl_Size objc,
			    void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd,
			    Tcl_Size pc);
MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
			    CmdFrame *cfPtr);
MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
			    CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int	TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId,
			    void *clientData, int *flagPtr, int value);
MODULE_SCOPE void	TclAsyncMarkFromNotifier(void);
MODULE_SCOPE double	TclBignumToDouble(const void *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    Tcl_Size strLen, const unsigned char *pattern,
			    Tcl_Size ptnLen, int flags);
MODULE_SCOPE double	TclCeil(const void *a);
MODULE_SCOPE void	TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void	TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE int	TclChannelGetBlockingMode(Tcl_Channel chan);
MODULE_SCOPE int	TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
			    Var *arrayPtr, Tcl_Obj *name, Tcl_Size index);
MODULE_SCOPE int	TclCheckEmptyString(Tcl_Obj *objPtr);
MODULE_SCOPE int	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE int	TclChanIsBinary(Tcl_Channel chan);
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int	TclCompareTwoNumbers(Tcl_Obj *valuePtr,
			    Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num,
			    Tcl_Size *loc);
MODULE_SCOPE void	TclContinuationsEnterDerived(Tcl_Obj *objPtr,
			    Tcl_Size start, Tcl_Size *clNext);







|



|





|



|


|







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
3343
3344
3345
			    Tcl_Obj *objv[], Tcl_Size objc,
			    void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd,
			    Tcl_Size pc);
MODULE_SCOPE void	TclArgumentBCRelease(Tcl_Interp *interp,
			    CmdFrame *cfPtr);
MODULE_SCOPE void	TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
			    CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE bool	TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId,
			    void *clientData, int *flagPtr, int value);
MODULE_SCOPE void	TclAsyncMarkFromNotifier(void);
MODULE_SCOPE double	TclBignumToDouble(const void *bignum);
MODULE_SCOPE bool	TclByteArrayMatch(const unsigned char *string,
			    Tcl_Size strLen, const unsigned char *pattern,
			    Tcl_Size ptnLen, int flags);
MODULE_SCOPE double	TclCeil(const void *a);
MODULE_SCOPE void	TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void	TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE bool	TclChannelGetBlockingMode(Tcl_Channel chan);
MODULE_SCOPE int	TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
			    Var *arrayPtr, Tcl_Obj *name, Tcl_Size index);
MODULE_SCOPE int	TclCheckEmptyString(Tcl_Obj *objPtr);
MODULE_SCOPE bool	TclChanCaughtErrorBypass(Tcl_Interp *interp,
			    Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE bool	TclChanIsBinary(Tcl_Channel chan);
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int	TclCompareTwoNumbers(Tcl_Obj *valuePtr,
			    Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num,
			    Tcl_Size *loc);
MODULE_SCOPE void	TclContinuationsEnterDerived(Tcl_Obj *objPtr,
			    Tcl_Size start, Tcl_Size *clNext);
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
			    const char *attributeName, Tcl_Size *indexPtr);
MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
			    const char *cmdName, Tcl_Namespace *nsPtr,
			    Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
			    void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    const char *encodingName);
MODULE_SCOPE int *	TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
			    int *modePtr, int flags);
MODULE_SCOPE CmdFrame *	TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int	TclGetCompletionCodeFromObj(Tcl_Interp *interp,
			    Tcl_Obj *value, int *code);
MODULE_SCOPE Proc *	TclGetLambdaFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    Tcl_Size *sizePtr);
MODULE_SCOPE int	TclGetLoadedLibraries(Tcl_Interp *interp,
				const char *targetName,
				const char *prefix);
MODULE_SCOPE int	TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
				Tcl_WideInt *);
MODULE_SCOPE int	TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE size_t	TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd;







|















|
<

|







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
			    const char *attributeName, Tcl_Size *indexPtr);
MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp,
			    const char *cmdName, Tcl_Namespace *nsPtr,
			    Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc,
			    void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    const char *encodingName);
MODULE_SCOPE bool *	TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
			    int *modePtr, int flags);
MODULE_SCOPE CmdFrame *	TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int	TclGetCompletionCodeFromObj(Tcl_Interp *interp,
			    Tcl_Obj *value, int *code);
MODULE_SCOPE Proc *	TclGetLambdaFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE Tcl_Obj *	TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE Tcl_Obj *	TclGetSourceFromFrame(CmdFrame *cfPtr, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE char *	TclGetStringStorage(Tcl_Obj *objPtr,
			    Tcl_Size *sizePtr);
MODULE_SCOPE int	TclGetLoadedLibraries(Tcl_Interp *interp,
			    const char *targetName, const char *prefix);

MODULE_SCOPE int	TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
			    Tcl_WideInt *);
MODULE_SCOPE int	TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE size_t	TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int	TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
			    Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj *	TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd;
3474
3475
3476
3477
3478
3479
3480
3481

3482
3483
3484
3485
3486
3487
3488
3489
3490
MODULE_SCOPE void	TclInitEncodingSubsystem(void);
MODULE_SCOPE void	TclInitIOSubsystem(void);
MODULE_SCOPE void	TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void	TclInitNamespaceSubsystem(void);
MODULE_SCOPE void	TclInitNotifier(void);
MODULE_SCOPE void	TclInitObjSubsystem(void);
MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int	TclIsBareword(int byte);

MODULE_SCOPE Tcl_Obj *	TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[],
			    int forceRelative);
MODULE_SCOPE Tcl_Obj *	TclGetHomeDirObj(Tcl_Interp *interp, const char *user);
MODULE_SCOPE Tcl_Obj *	TclResolveTildePath(Tcl_Interp *interp,
			    Tcl_Obj *pathObj);
MODULE_SCOPE Tcl_Obj *	TclResolveTildePathList(Tcl_Obj *pathsObj);
MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,







|
>

|







3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
MODULE_SCOPE void	TclInitEncodingSubsystem(void);
MODULE_SCOPE void	TclInitIOSubsystem(void);
MODULE_SCOPE void	TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void	TclInitNamespaceSubsystem(void);
MODULE_SCOPE void	TclInitNotifier(void);
MODULE_SCOPE void	TclInitObjSubsystem(void);
MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE bool	TclIsBareword(int byte);
MODULE_SCOPE bool	TclIsPureByteArray(Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Obj *	TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[],
			    bool forceRelative);
MODULE_SCOPE Tcl_Obj *	TclGetHomeDirObj(Tcl_Interp *interp, const char *user);
MODULE_SCOPE Tcl_Obj *	TclResolveTildePath(Tcl_Interp *interp,
			    Tcl_Obj *pathObj);
MODULE_SCOPE Tcl_Obj *	TclResolveTildePathList(Tcl_Obj *pathsObj);
MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,
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
			    const EnsembleImplMap map[]);
MODULE_SCOPE Tcl_Size	TclMaxListLength(const char *bytes, Tcl_Size numBytes,
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, Tcl_Size 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, Tcl_Size index);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    Tcl_Size objc, Tcl_Obj *const objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
			    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
MODULE_SCOPE Tcl_Size TclParseBackslash(const char *src,
			    Tcl_Size numBytes, Tcl_Size *readPtr, char *dst);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    const char *expected, const char *bytes,
			    Tcl_Size numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    Tcl_Size numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE Tcl_Size	TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);







|

|








|







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
			    const EnsembleImplMap map[]);
MODULE_SCOPE Tcl_Size	TclMaxListLength(const char *bytes, Tcl_Size numBytes,
			    const char **endPtr);
MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, Tcl_Size 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 bool	TclNokia770Doubles(void);
MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
MODULE_SCOPE bool	TclNamespaceDeleted(Namespace *nsPtr);
MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
			    Tcl_Obj *part2Ptr, const char *operation,
			    const char *reason, Tcl_Size index);
MODULE_SCOPE int	TclObjInvokeNamespace(Tcl_Interp *interp,
			    Tcl_Size objc, Tcl_Obj *const objv[],
			    Tcl_Namespace *nsPtr, int flags);
MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
			    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
MODULE_SCOPE Tcl_Size	TclParseBackslash(const char *src,
			    Tcl_Size numBytes, Tcl_Size *readPtr, char *dst);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    const char *expected, const char *bytes,
			    Tcl_Size numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    Tcl_Size numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE Tcl_Size	TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
MODULE_SCOPE void	TclpFinalizeSockets(void);
#ifdef _WIN32
MODULE_SCOPE void	TclInitSockets(void);
#else
#define TclInitSockets() /* do nothing */
#endif
struct addrinfo; /* forward declaration, needed for TclCreateSocketAddress */
MODULE_SCOPE int	TclCreateSocketAddress(Tcl_Interp *interp,
			    struct addrinfo **addrlist,
			    const char *host, int port, int willBind,
			    const char **errorMsgPtr);
MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc *proc, void *clientData,
			    size_t stackSize, int flags);
MODULE_SCOPE Tcl_Size	TclpFindVariable(const char *name, Tcl_Size *lengthPtr);







|







3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
MODULE_SCOPE void	TclpFinalizeSockets(void);
#ifdef _WIN32
MODULE_SCOPE void	TclInitSockets(void);
#else
#define TclInitSockets() /* do nothing */
#endif
struct addrinfo; /* forward declaration, needed for TclCreateSocketAddress */
MODULE_SCOPE bool	TclCreateSocketAddress(Tcl_Interp *interp,
			    struct addrinfo **addrlist,
			    const char *host, int port, int willBind,
			    const char **errorMsgPtr);
MODULE_SCOPE int	TclpThreadCreate(Tcl_ThreadId *idPtr,
			    Tcl_ThreadCreateProc *proc, void *clientData,
			    size_t stackSize, int flags);
MODULE_SCOPE Tcl_Size	TclpFindVariable(const char *name, Tcl_Size *lengthPtr);
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
			    void *data);
MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int	TclReToGlob(Tcl_Interp *interp, const char *reStr,
			    Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
			    int *quantifiersFoundPtr);
MODULE_SCOPE Tcl_Size	TclScanElement(const char *string, Tcl_Size length,
			    char *flagPtr);
MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix);
MODULE_SCOPE void	TclSetBignumInternalRep(Tcl_Obj *objPtr,
			    void *bignumValue);
MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp,







|
|







3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
			    void *data);
MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void	TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void	TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void	TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void	TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int	TclReToGlob(Tcl_Interp *interp, const char *reStr,
			    Tcl_Size reStrLen, Tcl_DString *dsPtr,
			    bool *exactPtr, bool *quantifiersFoundPtr);
MODULE_SCOPE Tcl_Size	TclScanElement(const char *string, Tcl_Size length,
			    char *flagPtr);
MODULE_SCOPE void	TclSetBgErrorHandler(Tcl_Interp *interp,
			    Tcl_Obj *cmdPrefix);
MODULE_SCOPE void	TclSetBignumInternalRep(Tcl_Obj *objPtr,
			    void *bignumValue);
MODULE_SCOPE int	TclSetBooleanFromAny(Tcl_Interp *interp,
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736

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

MODULE_SCOPE int	TclIsSpaceProc(int byte);
#define TclIsSpaceProcM(byte) \
    (((unsigned)(byte) > 0x20) ? 0 : TclIsSpaceProc(byte))

/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */








|

|







3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736

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

MODULE_SCOPE bool	TclIsSpaceProc(int byte);
#define TclIsSpaceProcM(byte) \
    (((unsigned)(byte) > 0x20) ? false : TclIsSpaceProc(byte))

/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */

4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120

/*
 * The new extended interface to the variable traces.
 */

MODULE_SCOPE int	TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
			    int flags, int leaveErrMsg, Tcl_Size index);

/*
 * So tclObj.c and tclDictObj.c can share these implementations.
 */

MODULE_SCOPE int	TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE size_t TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);

MODULE_SCOPE int	TclFullFinalizationRequested(void);

/*
 * TIP #542
 */

MODULE_SCOPE size_t	TclUniCharLen(const Tcl_UniChar *uniStr);
MODULE_SCOPE int	TclUniCharNcmp(const Tcl_UniChar *ucs,
			    const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE int	TclUniCharNcasecmp(const Tcl_UniChar *ucs,
			    const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE int	TclUniCharCaseMatch(const Tcl_UniChar *uniStr,
			    const Tcl_UniChar *uniPattern, int nocase);

/*
 * Just for the purposes of command-type registration.
 */

MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;







|







|

|










|
|







4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120

/*
 * The new extended interface to the variable traces.
 */

MODULE_SCOPE int	TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
			    int flags, bool leaveErrMsg, Tcl_Size index);

/*
 * So tclObj.c and tclDictObj.c can share these implementations.
 */

MODULE_SCOPE int	TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
MODULE_SCOPE size_t	TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);

MODULE_SCOPE bool	TclFullFinalizationRequested(void);

/*
 * TIP #542
 */

MODULE_SCOPE size_t	TclUniCharLen(const Tcl_UniChar *uniStr);
MODULE_SCOPE int	TclUniCharNcmp(const Tcl_UniChar *ucs,
			    const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE int	TclUniCharNcasecmp(const Tcl_UniChar *ucs,
			    const Tcl_UniChar *uct, size_t numChars);
MODULE_SCOPE bool	TclUniCharCaseMatch(const Tcl_UniChar *uniStr,
			    const Tcl_UniChar *uniPattern, bool nocase);

/*
 * Just for the purposes of command-type registration.
 */

MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
4337
4338
4339
4340
4341
4342
4343

4344
4345





4346
4347
4348
4349
4350
4351

4352
4353
4354
4355
4356

4357


4358
4359

4360

4361



4362
4363
4364
4365
4366
4367
4368
4369
4370
4371


4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386

4387
4388


4389
4390
4391
4392

4393
4394
4395
4396
4397

4398


4399
4400



4401
4402
4403
4404
4405

4406





4407
4408
4409
4410
4411
4412
4413
 *
 * Note that the optimiser should resolve the case (interp==NULL) at compile
 * time.
 */

#  define ALLOC_NOBJHIGH 1200


#  define TclAllocObjStorageEx(interp, objPtr)				\
    do {								\





	AllocCache *cachePtr;						\
	if (((interp) == NULL) ||					\
		((cachePtr = ((Interp *)(interp))->allocCache),		\
			(cachePtr->numObjects == 0))) {			\
	    (objPtr) = TclThreadAllocObj();				\
	} else {							\

	    (objPtr) = cachePtr->firstObjPtr;				\
	    cachePtr->firstObjPtr = (Tcl_Obj *)(objPtr)->internalRep.twoPtrValue.ptr1; \
	    --cachePtr->numObjects;					\
	}								\
    } while (0)




#  define TclFreeObjStorageEx(interp, objPtr)				\
    do {								\

	AllocCache *cachePtr;						\

	if (((interp) == NULL) ||					\



		((cachePtr = ((Interp *)(interp))->allocCache),		\
			((cachePtr->numObjects == 0) ||			\
			(cachePtr->numObjects >= ALLOC_NOBJHIGH)))) {	\
	    TclThreadFreeObj(objPtr);					\
	} else {							\
	    (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \
	    cachePtr->firstObjPtr = objPtr;				\
	    ++cachePtr->numObjects;					\
	}								\
    } while (0)



#else /* not PURIFY or USE_THREAD_ALLOC */

#if defined(USE_TCLALLOC) && USE_TCLALLOC
    MODULE_SCOPE void TclFinalizeAllocSubsystem();
    MODULE_SCOPE void TclInitAlloc();
#else
#   define USE_TCLALLOC 0
#endif

#if TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex	tclObjMutex;
#endif


#  define TclAllocObjStorageEx(interp, objPtr) \
    do {								\


	Tcl_MutexLock(&tclObjMutex);					\
	if (tclFreeObjList == NULL) {					\
	    TclAllocateFreeObjects();					\
	}								\

	(objPtr) = tclFreeObjList;					\
	tclFreeObjList = (Tcl_Obj *)					\
		tclFreeObjList->internalRep.twoPtrValue.ptr1;		\
	Tcl_MutexUnlock(&tclObjMutex);					\
    } while (0)




#  define TclFreeObjStorageEx(interp, objPtr) \
    do {								\



	Tcl_MutexLock(&tclObjMutex);					\
	(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \
	tclFreeObjList = (objPtr);					\
	Tcl_MutexUnlock(&tclObjMutex);					\
    } while (0)

#endif






#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
			    int line);

# define TclDbNewObj(objPtr, file, line) \
    do { \







>
|
<
>
>
>
>
>
|
<
<
|
|
<
>
|
|
|
<
<
>
|
>
>
|
<
>
|
>
|
>
>
>
|
|
<
|
|
|
|
|
<
<
>
>















>
|
<
>
>
|
|
|
<
>
|
|
|
|
<
>
|
>
>
|
<
>
>
>
|
|
|
|
<
>

>
>
>
>
>







4337
4338
4339
4340
4341
4342
4343
4344
4345

4346
4347
4348
4349
4350
4351


4352
4353

4354
4355
4356
4357


4358
4359
4360
4361
4362

4363
4364
4365
4366
4367
4368
4369
4370
4371

4372
4373
4374
4375
4376


4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395

4396
4397
4398
4399
4400

4401
4402
4403
4404
4405

4406
4407
4408
4409
4410

4411
4412
4413
4414
4415
4416
4417

4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
 *
 * Note that the optimiser should resolve the case (interp==NULL) at compile
 * time.
 */

#  define ALLOC_NOBJHIGH 1200

static inline Tcl_Obj *
TclAllocObjStorageExImpl(

    Interp *iPtr)
{
    if (iPtr == NULL) {
	return TclThreadAllocObj();
    }
    AllocCache *cachePtr = iPtr->allocCache;


    if (cachePtr->numObjects == 0) {
	return TclThreadAllocObj();

    }
    Tcl_Obj *objPtr = cachePtr->firstObjPtr;
    cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
    --cachePtr->numObjects;


    return objPtr;
}

static inline void
TclFreeObjStorageEx(

    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    if (interp == NULL) {
	TclThreadFreeObj(objPtr);
	return;
    }
    AllocCache *cachePtr = ((Interp *) interp)->allocCache;
    if (cachePtr->numObjects == 0 || cachePtr->numObjects >= ALLOC_NOBJHIGH) {

	TclThreadFreeObj(objPtr);
    } else {
	objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
	cachePtr->firstObjPtr = objPtr;
	++cachePtr->numObjects;


    }
}

#else /* not PURIFY or USE_THREAD_ALLOC */

#if defined(USE_TCLALLOC) && USE_TCLALLOC
    MODULE_SCOPE void TclFinalizeAllocSubsystem();
    MODULE_SCOPE void TclInitAlloc();
#else
#   define USE_TCLALLOC 0
#endif

#if TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex	tclObjMutex;
#endif

static inline Tcl_Obj *
TclAllocObjStorageExImpl(

    TCL_UNUSED(Interp *))
{
    Tcl_MutexLock(&tclObjMutex);
    if (tclFreeObjList == NULL) {
	TclAllocateFreeObjects();

    }
    Tcl_Obj *objPtr = tclFreeObjList;
    tclFreeObjList = (Tcl_Obj *)
	    tclFreeObjList->internalRep.twoPtrValue.ptr1;
    Tcl_MutexUnlock(&tclObjMutex);

    return objPtr;
}

static inline void
TclFreeObjStorageEx(

    TCL_UNUSED(Tcl_Interp *),
    Tcl_Obj *objPtr)
{
    Tcl_MutexLock(&tclObjMutex);
    objPtr->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList;
    tclFreeObjList = objPtr;
    Tcl_MutexUnlock(&tclObjMutex);

}
#endif

#define TclAllocObjStorageEx(interp, objPtr) \
    do {								\
	(objPtr) = TclAllocObjStorageExImpl((Interp *) (interp));	\
    } while (0)

#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
			    int line);

# define TclDbNewObj(objPtr, file, line) \
    do { \
4450
4451
4452
4453
4454
4455
4456

4457
4458
4459
4460
4461
4462
4463
4464
4465

4466
4467
4468
4469
4470
4471
4472
 *
 *----------------------------------------------------------------
 */

#define TclInitEmptyStringRep(objPtr) \
    ((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))


#define TclInitStringRep(objPtr, bytePtr, len) \
    if ((len) == 0) {							\
	TclInitEmptyStringRep(objPtr);					\
    } else {								\
	(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U);		\
	memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
	(objPtr)->bytes[len] = '\0';					\
	(objPtr)->length = (len);					\
    }


#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
    ((((len) == 0) ? (							\
	TclInitEmptyStringRep(objPtr)					\
    ) : (								\
	(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U),		\
	(objPtr)->length = ((objPtr)->bytes) ?				\







>
|
|
|
|
|
|
|
|

>







4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
 *
 *----------------------------------------------------------------
 */

#define TclInitEmptyStringRep(objPtr) \
    ((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))

static inline void
TclInitStringRep(Tcl_Obj *objPtr, const char *bytePtr, Tcl_Size len) {
    if (len == 0) {
	TclInitEmptyStringRep(objPtr);
    } else {
	objPtr->bytes = (char *)Tcl_Alloc(len + 1U);
	memcpy(objPtr->bytes, bytePtr ? bytePtr : &tclEmptyString, len);
	objPtr->bytes[len] = '\0';
	objPtr->length = len;
    }
}

#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
    ((((len) == 0) ? (							\
	TclInitEmptyStringRep(objPtr)					\
    ) : (								\
	(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U),		\
	(objPtr)->length = ((objPtr)->bytes) ?				\
4492
4493
4494
4495
4496
4497
4498

4499
4500
4501
4502
4503
4504
4505



4506
4507
4508
4509
4510
4511

4512
4513
4514

4515
4516

4517
4518

4519
4520
4521
4522
4523
4524
4525
4526

4527
4528
4529
4530

4531
4532
4533


4534
4535
4536
4537
4538
4539
4540
#define TclGetStringFromObj(objPtr, lenPtr) \
    ((objPtr)->bytes							\
	    ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes)		\
	    : (Tcl_GetStringFromObj)((objPtr), (lenPtr)))

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

 * Macro used by the Tcl core to clean out an object's internal
 * representation. Does not actually reset the rep's bytes. The ANSI C
 * "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclFreeInternalRep(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */




#define TclFreeInternalRep(objPtr) \
    if ((objPtr)->typePtr != NULL) {					\
	if ((objPtr)->typePtr->freeIntRepProc != NULL) {		\
	    (objPtr)->typePtr->freeIntRepProc(objPtr);			\
	}								\

	(objPtr)->typePtr = NULL;					\
    }


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

 * Macro used by the Tcl core to clean out an object's string representation.
 * The ANSI C "prototype" for this macro is:

 *
 * MODULE_SCOPE void	TclInvalidateStringRep(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */

#define TclInvalidateStringRep(objPtr) \
    do {								\
	Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr);			\

	if (_isobjPtr->bytes != NULL) {					\
	    if (_isobjPtr->bytes != &tclEmptyString) {			\
		Tcl_Free((void *)_isobjPtr->bytes);			\
	    }								\

	    _isobjPtr->bytes = NULL;					\
	}								\
    } while (0)



/*
 * These form part of the native filesystem support. They are needed here
 * because we have a few native filesystem functions (which are the same for
 * win/unix) in this file.
 */








>
|
|
<

<


>
>
>
|
<
|
|
|
<
>
|

|
>


>
|
<
>

<


|
|
<
|
>
|
|
|
<
>
|
<
<
>
>







4512
4513
4514
4515
4516
4517
4518
4519
4520
4521

4522

4523
4524
4525
4526
4527
4528

4529
4530
4531

4532
4533
4534
4535
4536
4537
4538
4539
4540

4541
4542

4543
4544
4545
4546

4547
4548
4549
4550
4551

4552
4553


4554
4555
4556
4557
4558
4559
4560
4561
4562
#define TclGetStringFromObj(objPtr, lenPtr) \
    ((objPtr)->bytes							\
	    ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes)		\
	    : (Tcl_GetStringFromObj)((objPtr), (lenPtr)))

/*
 *----------------------------------------------------------------
 *
 * Inline function used by the Tcl core to clean out an object's internal
 * representation. Does not actually reset the rep's bytes.

 *

 *----------------------------------------------------------------
 */
static inline void
TclFreeInternalRep(
    Tcl_Obj *objPtr)
{

    if (objPtr->typePtr != NULL) {
	if (objPtr->typePtr->freeIntRepProc != NULL) {
	    objPtr->typePtr->freeIntRepProc(objPtr);

	}
	objPtr->typePtr = NULL;
    }
}

/*
 *----------------------------------------------------------------
 *
 * Inline function used by the Tcl core to clean out an object's string

 * representation.
 *

 *----------------------------------------------------------------
 */
static inline void
TclInvalidateStringRep(

    Tcl_Obj *objPtr)
{
    if (objPtr->bytes != NULL) {
	if (objPtr->bytes != &tclEmptyString) {
	    Tcl_Free((void *) objPtr->bytes);

	}
	objPtr->bytes = NULL;


    }
}

/*
 * These form part of the native filesystem support. They are needed here
 * because we have a few native filesystem functions (which are the same for
 * win/unix) in this file.
 */

4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to test whether an object has a
 * string representation (or is a 'pure' internal value).
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclHasStringRep(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */

#define TclHasStringRep(objPtr) \
    ((objPtr)->bytes != NULL)

/*







|







4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to test whether an object has a
 * string representation (or is a 'pure' internal value).
 * The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE bool	TclHasStringRep(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */

#define TclHasStringRep(objPtr) \
    ((objPtr)->bytes != NULL)

/*
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
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
4638
4639

4640
4641
4642
4643
4644
4645
4646
4647

4648
4649
4650
4651
4652
4653
4654
	    (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:
 *
 * MODULE_SCOPE void	TclGrowTokenArray(Tcl_Token *tokenPtr, int used,
 *				int available, int append,
 *				Tcl_Token *staticPtr);
 * MODULE_SCOPE void	TclGrowParseTokenArray(Tcl_Parse *parsePtr,
 *				int append);
 *----------------------------------------------------------------
 */

/* General tuning for minimum growth in Tcl growth algorithms */
#ifndef TCL_MIN_GROWTH
#  ifdef TCL_GROWTH_MIN_ALLOC
     /* Support for any legacy tuners */
#    define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
#  else
#    define TCL_MIN_GROWTH 1024
#  endif
#endif

/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif






/* TODO - code below does not check for integer overflow */
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
    do {								\
	Tcl_Size _needed = (used) + (append);				\
	if (_needed > (available)) {					\
	    Tcl_Size allocated = 2 * _needed;				\
	    Tcl_Token *oldPtr = (tokenPtr);				\
	    Tcl_Token *newPtr;						\
	    if (oldPtr == (staticPtr)) {				\
		oldPtr = NULL;						\
	    }								\

	    newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr,	\
		    allocated * sizeof(Tcl_Token));			\
	    if (newPtr == NULL) {					\
		allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH;	\
		newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr,	\
			allocated * sizeof(Tcl_Token));			\
	    }								\

	    (available) = allocated;					\
	    if (oldPtr == NULL) {					\
		memcpy(newPtr, staticPtr,				\
			(used) * sizeof(Tcl_Token));			\
	    }								\

	    (tokenPtr) = newPtr;					\
	}								\
    } while (0)

#define TclGrowParseTokenArray(parsePtr, append)			\
    TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens,	\
	    (parsePtr)->tokensAvailable, (append),			\
	    (parsePtr)->staticTokens)


/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core get a unicode char from a utf string. It checks
 * to see if we have a one-byte utf char before calling the real
 * Tcl_UtfToUniChar, as this will save a lot of time for primarily ASCII
 * string handling. The macro's expression result is 1 for the 1-byte case or







|
|
<
<
<
<
<
<
<


















>
>
>
>
>
|
|
<
|
|
|
|
<
|
|
<
>
|
|
|
|
|
|
<
>
|
|
|
|
<
>
|
<
<
|
<
<
<
<
>







4605
4606
4607
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
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
	    (bignum).alloc = (bignumPayload >> 15) & 0x7FFF;		\
	    (bignum).used = bignumPayload & 0x7FFF;			\
	}								\
    } while (0)

/*
 *----------------------------------------------------------------
 * Inline function used by the Tcl core to grow Tcl_Token arrays. It uses the
 * same growth algorithm as used in tclStringObj.c for growing strings.







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

/* General tuning for minimum growth in Tcl growth algorithms */
#ifndef TCL_MIN_GROWTH
#  ifdef TCL_GROWTH_MIN_ALLOC
     /* Support for any legacy tuners */
#    define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
#  else
#    define TCL_MIN_GROWTH 1024
#  endif
#endif

/* Token growth tuning, default to the general value. */
#ifndef TCL_MIN_TOKEN_GROWTH
#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
#endif

static inline void
TclGrowParseTokenArray(
    Tcl_Parse *parsePtr,
    Tcl_Size append)
{
    /* TODO - code below does not check for integer overflow */


    Tcl_Size needed = parsePtr->numTokens + append;
    if (needed > parsePtr->tokensAvailable) {
	Tcl_Size allocated = 2 * needed;
	Tcl_Token *oldPtr = parsePtr->tokenPtr;

	if (oldPtr == parsePtr->staticTokens) {
	    oldPtr = NULL;

	}
	Tcl_Token *newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr,
		allocated * sizeof(Tcl_Token));
	if (newPtr == NULL) {
	    allocated = needed + append + TCL_MIN_TOKEN_GROWTH;
	    newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr,
		    allocated * sizeof(Tcl_Token));

	}
	parsePtr->tokensAvailable = allocated;
	if (oldPtr == NULL) {
	    memcpy(newPtr, parsePtr->staticTokens,
		    parsePtr->numTokens * sizeof(Tcl_Token));

	}
	parsePtr->tokenPtr = newPtr;


    }




}

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core get a unicode char from a utf string. It checks
 * to see if we have a one-byte utf char before calling the real
 * Tcl_UtfToUniChar, as this will save a lot of time for primarily ASCII
 * string handling. The macro's expression result is 1 for the 1-byte case or
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700

4701
4702

4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713













4714
4715
4716
4717
4718
4719
4720
	    _count += Tcl_NumUtfChars((bytes) + _count, _i);		\
	}								\
	(numChars) = _count;						\
    } while (0);

/*
 *----------------------------------------------------------------
 * Macro that encapsulates the logic that determines when it is safe to
 * interpret a string as a byte array directly. In summary, the object must be
 * a byte array and must not have a string representation (as the operations
 * that it is used in are defined on strings, not byte arrays). Theoretically
 * it is possible to also be efficient in the case where the object's bytes
 * field is filled by generation from the byte array (c.f. list canonicality)
 * but we don't do that at the moment since this is purely about efficiency.
 * The ANSI C "prototype" for this macro is:

 *
 * MODULE_SCOPE int	TclIsPureByteArray(Tcl_Obj *objPtr);

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

MODULE_SCOPE int	TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
    (((objPtr)->bytes == NULL) && TclHasInternalRep((objPtr), &tclDictType))
#define TclHasInternalRep(objPtr, type) \
    ((objPtr)->typePtr == (type))
#define TclFetchInternalRep(objPtr, type) \
    (TclHasInternalRep((objPtr), (type)) ? &(objPtr)->internalRep : NULL)














/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to increment a namespace's export epoch
 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);
 *----------------------------------------------------------------







|
<
<
<
<
<
<
|
>
|
|
>



<
<
<





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







4699
4700
4701
4702
4703
4704
4705
4706






4707
4708
4709
4710
4711
4712
4713
4714



4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
	    _count += Tcl_NumUtfChars((bytes) + _count, _i);		\
	}								\
	(numChars) = _count;						\
    } while (0);

/*
 *----------------------------------------------------------------
 * Macro that encapsulates the logic that tests for an internal representation






 * and fetches it if it is present. The ANSI C "prototypes" for these macros
 * are:
 * 
 * bool			TclHasInternalRep(Tcl_Obj *objPtr, Tcl_ObjType *type);
 * Tcl_ObjInternalRep *	TclFetchInternalRep(Tcl_Obj *objPtr, Tcl_ObjType *type);
 *----------------------------------------------------------------
 */




#define TclHasInternalRep(objPtr, type) \
    ((objPtr)->typePtr == (type))
#define TclFetchInternalRep(objPtr, type) \
    (TclHasInternalRep((objPtr), (type)) ? &(objPtr)->internalRep : NULL)

/*
 *----------------------------------------------------------------
 * Macro that encapsulates the logic that determines when it is safe to
 * interpret a value as a dict directly. In summary, the object must be
 * a dict and must not have a string representation. The ANSI C "prototype"
 * for this macro is:
 * 
 * MODULE_SCOPE bool	TclIsPureDict(Tcl_Obj *objPtr);
 *----------------------------------------------------------------
 */
#define TclIsPureDict(objPtr) \
    (((objPtr)->bytes == NULL) && TclHasInternalRep((objPtr), &tclDictType))

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to increment a namespace's export epoch
 * counter. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE void	TclInvalidateNsCmdLookup(Namespace *nsPtr);
 *----------------------------------------------------------------
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to check whether a pattern has any characters
 * special to [string match]. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE int	TclMatchIsTrivial(const char *pattern);
 *----------------------------------------------------------------
 */

#define TclMatchIsTrivial(pattern) \
    (strpbrk((pattern), "*[?\\") == NULL)

/*







|







4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to check whether a pattern has any characters
 * special to [string match]. The ANSI C "prototype" for this macro is:
 *
 * MODULE_SCOPE bool	TclMatchIsTrivial(const char *pattern);
 *----------------------------------------------------------------
 */

#define TclMatchIsTrivial(pattern) \
    (strpbrk((pattern), "*[?\\") == NULL)

/*
Changes to generic/tclInterp.c.
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
static Tcl_Interp *	GetInterp2(Tcl_Interp *interp, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
static Tcl_InterpDeleteProc InterpInfoDeleteProc;
static int		ChildBgerror(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
static Tcl_Interp *	ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    int safe);
static int		ChildDebugCmd(Tcl_Interp *interp,
			    Tcl_Interp *childInterp,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
static int		ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
static int		ChildExpose(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Size objc,







|







236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
static Tcl_Interp *	GetInterp2(Tcl_Interp *interp, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
static Tcl_InterpDeleteProc InterpInfoDeleteProc;
static int		ChildBgerror(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
static Tcl_Interp *	ChildCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
			    bool safe);
static int		ChildDebugCmd(Tcl_Interp *interp,
			    Tcl_Interp *childInterp,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
static int		ChildEval(Tcl_Interp *interp, Tcl_Interp *childInterp,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
static int		ChildExpose(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Size objc,
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
	static const char *const createOptions[] = {
	    "-safe",	"--", NULL
	};
	enum option {
	    OPT_SAFE,	OPT_LAST
	} idx;

	int safe = Tcl_IsSafe(interp);

	/*
	 * Weird historical rules: "-safe" is accepted at the end, too.
	 */

	Tcl_Obj *childPtr = NULL;
	int last = 0;
	for (Tcl_Size i = 2; i < objc; i++) {
	    if ((last == 0) && (TclGetString(objv[i])[0] == '-')) {
		if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
			"option", 0, &idx) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (idx == OPT_SAFE) {
		    safe = 1;
		    continue;
		}
		i++;
		last = 1;
	    }
	    if (childPtr != NULL) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");







|














|







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
	static const char *const createOptions[] = {
	    "-safe",	"--", NULL
	};
	enum option {
	    OPT_SAFE,	OPT_LAST
	} idx;

	bool safe = Tcl_IsSafe(interp);

	/*
	 * Weird historical rules: "-safe" is accepted at the end, too.
	 */

	Tcl_Obj *childPtr = NULL;
	int last = 0;
	for (Tcl_Size i = 2; i < objc; i++) {
	    if ((last == 0) && (TclGetString(objv[i])[0] == '-')) {
		if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
			"option", 0, &idx) != TCL_OK) {
		    return TCL_ERROR;
		}
		if (idx == OPT_SAFE) {
		    safe = true;
		    continue;
		}
		i++;
		last = 1;
	    }
	    if (childPtr != NULL) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
	}
	childInterp = GetInterp(interp, objv[2]);
	if (childInterp == NULL) {
	    return TCL_ERROR;
	}
	return ChildEval(interp, childInterp, objc - 3, objv + 3);
    case OPT_EXISTS: {
	int exists = 1;

	childInterp = GetInterp2(interp, objc, objv);
	if (childInterp == NULL) {
	    if (objc > 3) {
		return TCL_ERROR;
	    }
	    Tcl_ResetResult(interp);
	    exists = 0;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
	return TCL_OK;
    }
    case OPT_EXPOSE:
	if ((objc < 4) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");







|







|







889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
	}
	childInterp = GetInterp(interp, objv[2]);
	if (childInterp == NULL) {
	    return TCL_ERROR;
	}
	return ChildEval(interp, childInterp, objc - 3, objv + 3);
    case OPT_EXISTS: {
	bool exists = true;

	childInterp = GetInterp2(interp, objc, objv);
	if (childInterp == NULL) {
	    if (objc > 3) {
		return TCL_ERROR;
	    }
	    Tcl_ResetResult(interp);
	    exists = false;
	}
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
	return TCL_OK;
    }
    case OPT_EXPOSE:
	if ((objc < 4) || (objc > 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
ChildCreate(
    Tcl_Interp *interp,		/* Interp. to start search from. */
    Tcl_Obj *pathPtr,		/* Path (name) of child to create. */
    int safe)			/* Should we make it "safe"? */
{
    Tcl_Interp *parentInterp, *childInterp;
    Child *childPtr;
    InterpInfo *parentInfoPtr;
    Tcl_HashEntry *hPtr;
    const char *path;
    int isNew;







|







2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
 *----------------------------------------------------------------------
 */

static Tcl_Interp *
ChildCreate(
    Tcl_Interp *interp,		/* Interp. to start search from. */
    Tcl_Obj *pathPtr,		/* Path (name) of child to create. */
    bool safe)			/* Should we make it "safe"? */
{
    Tcl_Interp *parentInterp, *childInterp;
    Child *childPtr;
    InterpInfo *parentInfoPtr;
    Tcl_HashEntry *hPtr;
    const char *path;
    int isNew;
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
	parentInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (parentInterp == NULL) {
	    return NULL;
	}
	path = TclGetString(objv[objc - 1]);
    }
    if (safe == 0) {
	safe = Tcl_IsSafe(parentInterp);
    }

    parentInfoPtr = INTERP_INFO(parentInterp);
    hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path,
	    &isNew);
    if (isNew == 0) {
	TclPrintfResult(interp,
		"interpreter named \"%s\" already exists, cannot create",
		path);
	return NULL;
    }

    childInterp = Tcl_CreateInterp();







|






|







2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
	parentInterp = GetInterp(interp, objPtr);
	Tcl_DecrRefCount(objPtr);
	if (parentInterp == NULL) {
	    return NULL;
	}
	path = TclGetString(objv[objc - 1]);
    }
    if (!safe) {
	safe = Tcl_IsSafe(parentInterp);
    }

    parentInfoPtr = INTERP_INFO(parentInterp);
    hPtr = Tcl_CreateHashEntry(&parentInfoPtr->parent.childTable, path,
	    &isNew);
    if (!isNew) {
	TclPrintfResult(interp,
		"interpreter named \"%s\" already exists, cannot create",
		path);
	return NULL;
    }

    childInterp = Tcl_CreateInterp();
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
int
Tcl_IsSafe(
    Tcl_Interp *interp)		/* Is this interpreter "safe" ? */
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr == NULL) {
	return 0;
    }
    return (iPtr->flags & SAFE_INTERP) ? 1 : 0;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeSafe --
 *







|

|







3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
int
Tcl_IsSafe(
    Tcl_Interp *interp)		/* Is this interpreter "safe" ? */
{
    Interp *iPtr = (Interp *) interp;

    if (iPtr == NULL) {
	return false;
    }
    return (iPtr->flags & SAFE_INTERP) ? true : false;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeSafe --
 *
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358

    if (iPtr->limit.active != 0) {
	int ticker = ++iPtr->limit.granularityTicker;

	if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
		((iPtr->limit.cmdGranularity == 1) ||
		    (ticker % iPtr->limit.cmdGranularity == 0))) {
	    return 1;
	}
	if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
		((iPtr->limit.timeGranularity == 1) ||
		    (ticker % iPtr->limit.timeGranularity == 0))) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitCheck --
 *







|




|


|







3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358

    if (iPtr->limit.active != 0) {
	int ticker = ++iPtr->limit.granularityTicker;

	if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
		((iPtr->limit.cmdGranularity == 1) ||
		    (ticker % iPtr->limit.cmdGranularity == 0))) {
	    return true;
	}
	if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
		((iPtr->limit.timeGranularity == 1) ||
		    (ticker % iPtr->limit.timeGranularity == 0))) {
	    return true;
	}
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LimitCheck --
 *
Changes to generic/tclLink.c.
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
 *
 *	Helper functions for LinkTraceProc and ObjValue. These are all
 *	factored out here to make those functions simpler.
 *
 *----------------------------------------------------------------------
 */

static inline int
GetInt(
    Tcl_Obj *objPtr,
    int *intPtr)
{
    return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
	    && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
}

static inline int
GetWide(
    Tcl_Obj *objPtr,
    Tcl_WideInt *widePtr)
{
    if (TclGetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
	int intValue;

	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
	    return 1;
	}
	*widePtr = intValue;
    }
    return 0;
}

static inline int
GetUWide(
    Tcl_Obj *objPtr,
    Tcl_WideUInt *uwidePtr)
{
    if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) {
	int intValue;

	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
	    return 1;
	}
	*uwidePtr = intValue;
    }
    return 0;
}

static inline int
GetDouble(
    Tcl_Obj *objPtr,
    double *dblPtr)
{
    if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
	return 0;
    } else {
#ifdef ACCEPT_NAN
	Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);

	if (irPtr != NULL) {
	    *dblPtr = irPtr->doubleValue;
	    return 0;
	}
#endif /* ACCEPT_NAN */
	return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
    }
}

static inline int
EqualDouble(
    double a,
    double b)
{
    return (a == b)
#ifdef ACCEPT_NAN
	|| (isnan(a) && isnan(b))
#endif /* ACCEPT_NAN */
	;
}

static inline int
IsSpecial(
    double a)
{
    return isinf(a)
#ifdef ACCEPT_NAN
	|| isnan(a)
#endif /* ACCEPT_NAN */







|








|








|



|


|








|



|


|





|






|






|











|







466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
 *
 *	Helper functions for LinkTraceProc and ObjValue. These are all
 *	factored out here to make those functions simpler.
 *
 *----------------------------------------------------------------------
 */

static inline bool
GetInt(
    Tcl_Obj *objPtr,
    int *intPtr)
{
    return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
	    && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
}

static inline bool
GetWide(
    Tcl_Obj *objPtr,
    Tcl_WideInt *widePtr)
{
    if (TclGetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
	int intValue;

	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
	    return true;
	}
	*widePtr = intValue;
    }
    return false;
}

static inline bool
GetUWide(
    Tcl_Obj *objPtr,
    Tcl_WideUInt *uwidePtr)
{
    if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) {
	int intValue;

	if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
	    return true;
	}
	*uwidePtr = intValue;
    }
    return false;
}

static inline bool
GetDouble(
    Tcl_Obj *objPtr,
    double *dblPtr)
{
    if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
	return false;
    } else {
#ifdef ACCEPT_NAN
	Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);

	if (irPtr != NULL) {
	    *dblPtr = irPtr->doubleValue;
	    return false;
	}
#endif /* ACCEPT_NAN */
	return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
    }
}

static inline bool
EqualDouble(
    double a,
    double b)
{
    return (a == b)
#ifdef ACCEPT_NAN
	|| (isnan(a) && isnan(b))
#endif /* ACCEPT_NAN */
	;
}

static inline bool
IsSpecial(
    double a)
{
    return isinf(a)
#ifdef ACCEPT_NAN
	|| isnan(a)
#endif /* ACCEPT_NAN */
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
    TCL_UNUSED(const char *) /*name2*/,
				/* Links can only be made to global variables,
				 * so we can find them with need to resolve
				 * caller-supplied name in caller context. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *)clientData;
    int changed;
    Tcl_Size valueLength = 0;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    Tcl_WideUInt valueUWide;







<







683
684
685
686
687
688
689

690
691
692
693
694
695
696
    TCL_UNUSED(const char *) /*name2*/,
				/* Links can only be made to global variables,
				 * so we can find them with need to resolve
				 * caller-supplied name in caller context. */
    int flags)			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *)clientData;

    Tcl_Size valueLength = 0;
    const char *value;
    char **pp;
    Tcl_Obj *valueObj;
    int valueInt;
    Tcl_WideInt valueWide;
    Tcl_WideUInt valueUWide;
734
735
736
737
738
739
740

741
742
743
744
745
746
747
748
749
750
     */

    if (flags & TCL_TRACE_READS) {
	/*
	 * Variable arrays
	 */


	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
		    linkPtr->bytes);
	} else {
	    /* single variables */
	    switch (linkPtr->type) {
	    case TCL_LINK_INT:
	    case TCL_LINK_BOOLEAN:
		changed = (LinkedVar(int) != linkPtr->lastValue.i);
		break;







>


|







733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
     */

    if (flags & TCL_TRACE_READS) {
	/*
	 * Variable arrays
	 */

	bool changed;
	if (linkPtr->flags & LINK_ALLOC_LAST) {
	    changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
		    linkPtr->bytes) != 0;
	} else {
	    /* single variables */
	    switch (linkPtr->type) {
	    case TCL_LINK_INT:
	    case TCL_LINK_BOOLEAN:
		changed = (LinkedVar(int) != linkPtr->lastValue.i);
		break;
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
		break;
	    case TCL_LINK_FLOAT:
		changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f);
		break;
	    case TCL_LINK_STRING:
	    case TCL_LINK_CHARS:
	    case TCL_LINK_BINARY:
		changed = 1;
		break;
	    default:
		changed = 0;
		/* return (char *) "internal error: bad linked variable type"; */
	    }
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}







|


|







774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
		break;
	    case TCL_LINK_FLOAT:
		changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f);
		break;
	    case TCL_LINK_STRING:
	    case TCL_LINK_CHARS:
	    case TCL_LINK_BINARY:
		changed = true;
		break;
	    default:
		changed = false;
		/* return (char *) "internal error: bad linked variable type"; */
	    }
	}
	if (changed) {
	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
		    TCL_GLOBAL_ONLY);
	}
Changes to generic/tclListObj.c.
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
 *    Creation of a new list may sometimes be done as a span on existing
 *    storage instead of allocating new. The tradeoff is that if the
 *    original list is released, the new span-based list may hold on to
 *    more memory than desired. This function implements heuristics for
 *    deciding which option is better.
 *
 * Results:
 *    Returns non-0 if a span-based list is likely to be more optimal
 *    and 0 if not.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static inline int
ListSpanMerited(
    Tcl_Size length,		/* Length of the proposed span */
    Tcl_Size usedStorageLength,	/* Number of slots currently in used */
    Tcl_Size allocatedStorageLength) /* Length of the currently allocation */
{
    /*
     * Possible optimizations for future consideration
     * - heuristic LIST_SPAN_THRESHOLD
     * - currently, information about the sharing (ref count) of existing
     * storage is not passed. Perhaps it should be. For example if the
     * existing storage has a "large" ref count, then it might make sense
     * to do even a small span.
     */

    if (length < LIST_SPAN_THRESHOLD) {
	return 0;/* No span for small lists */
    }
    if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) {
	return 0; /* No span if less than 3/8 of allocation */
    }
    if (length < usedStorageLength / 2) {
	return 0; /* No span if less than half current storage */
    }

    return 1;
}

/*
 *------------------------------------------------------------------------
 *
 * ListRepFreeUnreferenced --
 *







|
|






|















|


|


|


|







284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
 *    Creation of a new list may sometimes be done as a span on existing
 *    storage instead of allocating new. The tradeoff is that if the
 *    original list is released, the new span-based list may hold on to
 *    more memory than desired. This function implements heuristics for
 *    deciding which option is better.
 *
 * Results:
 *    Returns true if a span-based list is likely to be more optimal
 *    and false if not.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static inline bool
ListSpanMerited(
    Tcl_Size length,		/* Length of the proposed span */
    Tcl_Size usedStorageLength,	/* Number of slots currently in used */
    Tcl_Size allocatedStorageLength) /* Length of the currently allocation */
{
    /*
     * Possible optimizations for future consideration
     * - heuristic LIST_SPAN_THRESHOLD
     * - currently, information about the sharing (ref count) of existing
     * storage is not passed. Perhaps it should be. For example if the
     * existing storage has a "large" ref count, then it might make sense
     * to do even a small span.
     */

    if (length < LIST_SPAN_THRESHOLD) {
	return false;	/* No span for small lists */
    }
    if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) {
	return false;	/* No span if less than 3/8 of allocation */
    }
    if (length < usedStorageLength / 2) {
	return false;	/* No span if less than half current storage */
    }

    return true;
}

/*
 *------------------------------------------------------------------------
 *
 * ListRepFreeUnreferenced --
 *
Changes to generic/tclListTypes.c.
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
 *    Stores 1 in *foundPtr if the value is found, 0 otherwise.
 */
int
TclListContainsValue(
    Tcl_Interp *interp,		/* Used for error messages. May be NULL */
    Tcl_Obj *needlePtr,		/* List to search */
    Tcl_Obj *hayPtr,		/* List to search */
    int *foundPtr)		/* Result */
{
    /* Adapted from TEBCresume. */
    /* FUTURES - use this in TEBCresume INST_LIST_IN as well */

    if (TclObjTypeHasProc(hayPtr, inOperProc)) {
	return TclObjTypeInOperator(interp, needlePtr, hayPtr, foundPtr);
    }

    Tcl_Size haySize;

    int status = TclListObjLength(interp, hayPtr, &haySize);
    if (status != TCL_OK) {
	return status;
    }

    if (haySize == 0) {
	*foundPtr = 0;
	return TCL_OK;
    }

    Tcl_Size needleLen;
    const char *needle = TclGetStringFromObj(needlePtr, &needleLen);

    /*







|
















|







189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
 *    Stores 1 in *foundPtr if the value is found, 0 otherwise.
 */
int
TclListContainsValue(
    Tcl_Interp *interp,		/* Used for error messages. May be NULL */
    Tcl_Obj *needlePtr,		/* List to search */
    Tcl_Obj *hayPtr,		/* List to search */
    int *foundPtr)		/* Result; should be a bool* */
{
    /* Adapted from TEBCresume. */
    /* FUTURES - use this in TEBCresume INST_LIST_IN as well */

    if (TclObjTypeHasProc(hayPtr, inOperProc)) {
	return TclObjTypeInOperator(interp, needlePtr, hayPtr, foundPtr);
    }

    Tcl_Size haySize;

    int status = TclListObjLength(interp, hayPtr, &haySize);
    if (status != TCL_OK) {
	return status;
    }

    if (haySize == 0) {
	*foundPtr = false;
	return TCL_OK;
    }

    Tcl_Size needleLen;
    const char *needle = TclGetStringFromObj(needlePtr, &needleLen);

    /*
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
	    return TCL_ERROR;
	}
	assert(hayElemObj != NULL); // Should never be NULL for i < haySize
	Tcl_Size hayElemLen;
	const char *hayElem = TclGetStringFromObj(hayElemObj, &hayElemLen);
	if (needleLen == hayElemLen &&
		memcmp(needle, hayElem, needleLen) == 0) {
	    *foundPtr = 1;
	    return TCL_OK;
	}
    }
    *foundPtr = 0;
    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * TclAbstractListUpdateString --







|



|







240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
	    return TCL_ERROR;
	}
	assert(hayElemObj != NULL); // Should never be NULL for i < haySize
	Tcl_Size hayElemLen;
	const char *hayElem = TclGetStringFromObj(hayElemObj, &hayElemLen);
	if (needleLen == hayElemLen &&
		memcmp(needle, hayElem, needleLen) == 0) {
	    *foundPtr = true;
	    return TCL_OK;
	}
    }
    *foundPtr = false;
    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * TclAbstractListUpdateString --
Changes to generic/tclLiteral.c.
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
 *	Find, or if necessary create, an object in the interpreter's literal
 *	table that has a string representation matching the argument
 *	string. If nsPtr!=NULL then only literals stored for the namespace are
 *	considered.
 *
 * Results:
 *	The literal object. If it was created in this call *newPtr is set to
 *	1, else 0. NULL is returned if newPtr==NULL and no literal is found.

 *
 * Side effects:
 *	Increments the ref count of the global LiteralEntry since the caller
 *	now holds a reference. If LITERAL_ON_HEAP is set in flags, this
 *	function is given ownership of the string: if an object is created
 *	then its string representation is set directly from string, otherwise
 *	the string is freed. Typically, a caller sets LITERAL_ON_HEAP if







|
>







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 *	Find, or if necessary create, an object in the interpreter's literal
 *	table that has a string representation matching the argument
 *	string. If nsPtr!=NULL then only literals stored for the namespace are
 *	considered.
 *
 * Results:
 *	The literal object. If it was created in this call *newPtr is set to
 *	true, else false. NULL is returned if newPtr==NULL and no literal is
 *	found.
 *
 * Side effects:
 *	Increments the ref count of the global LiteralEntry since the caller
 *	now holds a reference. If LITERAL_ON_HEAP is set in flags, this
 *	function is given ownership of the string: if an object is created
 *	then its string representation is set directly from string, otherwise
 *	the string is freed. Typically, a caller sets LITERAL_ON_HEAP if
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
TclCreateLiteral(
    Interp *iPtr,
    const char *bytes,		/* The start of the string. Note that this is
				 * not a NUL-terminated string. */
    Tcl_Size length,		/* Number of bytes in the string. */
    size_t hash,		/* The string's hash. If the value is
				 * TCL_INDEX_NONE, it will be computed here. */
    int *newPtr,
    Namespace *nsPtr,
    int flags,
    LiteralEntry **globalPtrPtr)
{
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    size_t globalHash;








|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
TclCreateLiteral(
    Interp *iPtr,
    const char *bytes,		/* The start of the string. Note that this is
				 * not a NUL-terminated string. */
    Tcl_Size length,		/* Number of bytes in the string. */
    size_t hash,		/* The string's hash. If the value is
				 * TCL_INDEX_NONE, it will be computed here. */
    bool *newPtr,		/* Where to report if the literal was created */
    Namespace *nsPtr,
    int flags,
    LiteralEntry **globalPtrPtr)
{
    LiteralTable *globalTablePtr = &iPtr->literalTable;
    size_t globalHash;

213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
		    || ((objBytes[0] == bytes[0])
		    && (memcmp(objBytes, bytes, length) == 0)))) {
		/*
		 * A literal was found: return it
		 */

		if (newPtr) {
		    *newPtr = 0;
		}
		if (globalPtrPtr) {
		    *globalPtrPtr = globalPtr;
		}
		if (flags & LITERAL_ON_HEAP) {
		    Tcl_Free((void *)bytes);
		}
		if (globalPtr->refCount != TCL_INDEX_NONE) {
		    globalPtr->refCount++;
		}
		return objPtr;
	    }
	}
    }
    if (!newPtr) {
	if ((flags & LITERAL_ON_HEAP)) {
	    Tcl_Free((void *)bytes);
	}
	return NULL;
    }

    /*
     * The literal is new to the interpreter.
     */

    Tcl_Obj *objPtr;
    TclNewObj(objPtr);
    if ((flags & LITERAL_ON_HEAP)) {
	objPtr->bytes = (char *) bytes;
	objPtr->length = length;
    } else if (!TclAttemptInitStringRep(objPtr, bytes, length)) {
	Tcl_DecrRefCount(objPtr);
	return NULL;
    }

    /* Should the new literal be shared globally? */

    if ((flags & LITERAL_UNSHARED)) {
	/*
	 * No, do *not* add it the global literal table
	 * Make clear, that no global value is returned
	 */
	if (globalPtrPtr != NULL) {
	    *globalPtrPtr = NULL;
	}







|















|











|









|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
		    || ((objBytes[0] == bytes[0])
		    && (memcmp(objBytes, bytes, length) == 0)))) {
		/*
		 * A literal was found: return it
		 */

		if (newPtr) {
		    *newPtr = false;
		}
		if (globalPtrPtr) {
		    *globalPtrPtr = globalPtr;
		}
		if (flags & LITERAL_ON_HEAP) {
		    Tcl_Free((void *)bytes);
		}
		if (globalPtr->refCount != TCL_INDEX_NONE) {
		    globalPtr->refCount++;
		}
		return objPtr;
	    }
	}
    }
    if (!newPtr) {
	if (flags & LITERAL_ON_HEAP) {
	    Tcl_Free((void *)bytes);
	}
	return NULL;
    }

    /*
     * The literal is new to the interpreter.
     */

    Tcl_Obj *objPtr;
    TclNewObj(objPtr);
    if (flags & LITERAL_ON_HEAP) {
	objPtr->bytes = (char *) bytes;
	objPtr->length = length;
    } else if (!TclAttemptInitStringRep(objPtr, bytes, length)) {
	Tcl_DecrRefCount(objPtr);
	return NULL;
    }

    /* Should the new literal be shared globally? */

    if (flags & LITERAL_UNSHARED) {
	/*
	 * No, do *not* add it the global literal table
	 * Make clear, that no global value is returned
	 */
	if (globalPtrPtr != NULL) {
	    *globalPtrPtr = NULL;
	}
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

    if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
	RebuildLiteralTable(globalTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable(iPtr);
    {
	int found = 0;
	for (size_t i=0 ; i<globalTablePtr->numBuckets ; i++) {
	    for (LiteralEntry *entryPtr=globalTablePtr->buckets[i];
		    entryPtr!=NULL ; entryPtr=entryPtr->nextPtr) {
		if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
		    found = 1;
		    goto doneVerifyLoop;
		}
	    }
	}
    doneVerifyLoop:
	if (!found) {
	    Tcl_Panic("%s: literal \"%.*s\" wasn't global",
		    "TclRegisterLiteral", (length>60? 60 : (int)length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numLiteralsCreated++;
    iPtr->stats.totalLitStringBytes += (double) (length + 1);
    iPtr->stats.currentLitStringBytes += (double) (length + 1);
    iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/

    if (globalPtrPtr) {
	*globalPtrPtr = globalPtr;
    }
    *newPtr = 1;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFetchLiteral --







<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<













|







293
294
295
296
297
298
299

300
301
302
303
304
305
306
307
308
309
310
311
312
313

314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334

    if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
	RebuildLiteralTable(globalTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyGlobalLiteralTable(iPtr);

    bool found = false;
    for (size_t i=0 ; i<globalTablePtr->numBuckets ; i++) {
	for (LiteralEntry *entryPtr=globalTablePtr->buckets[i];
		entryPtr!=NULL ; entryPtr=entryPtr->nextPtr) {
	    if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
		found = true;
		goto doneVerifyLoop;
	    }
	}
    }
  doneVerifyLoop:
    if (!found) {
	Tcl_Panic("%s: literal \"%.*s\" wasn't global",
		"TclRegisterLiteral", (length>60? 60 : (int)length), bytes);

    }
#endif /*TCL_COMPILE_DEBUG*/

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numLiteralsCreated++;
    iPtr->stats.totalLitStringBytes += (double) (length + 1);
    iPtr->stats.currentLitStringBytes += (double) (length + 1);
    iPtr->stats.literalCount[TclLog2(length)]++;
#endif /*TCL_COMPILE_STATS*/

    if (globalPtrPtr) {
	*globalPtrPtr = globalPtr;
    }
    *newPtr = true;
    return objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFetchLiteral --
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
	nsPtr = NULL;
    }

    /*
     * Is it in the interpreter's global literal table? If not, create it.
     */

    int isNew;
    LiteralEntry *globalPtr = NULL;
    Tcl_Obj *objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew,
	    nsPtr, flags, &globalPtr);
    size_t objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);

#ifdef TCL_COMPILE_DEBUG
    if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) {







|







452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
	nsPtr = NULL;
    }

    /*
     * Is it in the interpreter's global literal table? If not, create it.
     */

    bool isNew;
    LiteralEntry *globalPtr = NULL;
    Tcl_Obj *objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew,
	    nsPtr, flags, &globalPtr);
    size_t objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);

#ifdef TCL_COMPILE_DEBUG
    if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) {
729
730
731
732
733
734
735
736
737
738
739
740
741
742

743
744
745
746

747
748
749
750
751
752
753
754
755
756
757
758
759
760

    if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
	RebuildLiteralTable(localTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(envPtr);
    {
	int found = 0;
	for (size_t i=0 ; i<localTablePtr->numBuckets ; i++) {
	    for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
		    localPtr=localPtr->nextPtr) {
		if (localPtr->objPtr == objPtr) {
		    found = 1;

		}
	    }
	}


	if (!found) {
	    Tcl_Size length;
	    char *bytes = TclGetStringFromObj(objPtr, &length);
	    Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
		    "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes);
	}
    }
#endif /*TCL_COMPILE_DEBUG*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------







<
|
|
|
|
|
|
>
|
|
|

>
|
|
|
|
|
|
<







728
729
730
731
732
733
734

735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752

753
754
755
756
757
758
759

    if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
	RebuildLiteralTable(localTablePtr);
    }

#ifdef TCL_COMPILE_DEBUG
    TclVerifyLocalLiteralTable(envPtr);

    bool found = false;
    for (size_t i=0 ; i<localTablePtr->numBuckets ; i++) {
	for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
		localPtr=localPtr->nextPtr) {
	    if (localPtr->objPtr == objPtr) {
		found = true;
		goto doneVerifyLoop;
	    }
	}
    }

  doneVerifyLoop:
    if (!found) {
	Tcl_Size length;
	char *bytes = TclGetStringFromObj(objPtr, &length);
	Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
		"AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes);
}

#endif /*TCL_COMPILE_DEBUG*/

    return objIndex;
}

/*
 *----------------------------------------------------------------------
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
	/*
	 * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must
	 * code a Tcl_Realloc equivalent for ourselves.
	 */

	newArrayPtr = (LiteralEntry *)Tcl_Alloc(newSize);
	memcpy(newArrayPtr, currArrayPtr, currBytes);
	envPtr->mallocedLiteralArray = 1;
    }

    /*
     * Update the local literal table's bucket array.
     */

    if (currArrayPtr != newArrayPtr) {







|







803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
	/*
	 * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must
	 * code a Tcl_Realloc equivalent for ourselves.
	 */

	newArrayPtr = (LiteralEntry *)Tcl_Alloc(newSize);
	memcpy(newArrayPtr, currArrayPtr, currBytes);
	envPtr->mallocedLiteralArray = true;
    }

    /*
     * Update the local literal table's bucket array.
     */

    if (currArrayPtr != newArrayPtr) {
Changes to generic/tclLoad.c.
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
 * Prototypes for functions that are private to this file:
 */

static void	LoadCleanupProc(void *clientData,
		    Tcl_Interp *interp);
static int	IsStatic(LoadedLibrary *libraryPtr);
static int	UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
		    LoadedLibrary *library, int keepLibrary,
		    const char *fullFileName, int interpExiting);

static int
IsStatic(
    LoadedLibrary *libraryPtr)
{
    return (libraryPtr->fileName[0] == '\0');
}







|
|







95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
 * Prototypes for functions that are private to this file:
 */

static void	LoadCleanupProc(void *clientData,
		    Tcl_Interp *interp);
static int	IsStatic(LoadedLibrary *libraryPtr);
static int	UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
		    LoadedLibrary *library, bool keepLibrary,
		    const char *fullFileName, bool interpExiting);

static int
IsStatic(
    LoadedLibrary *libraryPtr)
{
    return (libraryPtr->fileName[0] == '\0');
}
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;
    LoadedLibrary *libraryPtr, *defaultPtr;
    Tcl_DString pfx, tmp, initName, safeInitName;
    Tcl_DString unloadName, safeUnloadName;
    int code, namesMatch, filesMatch;
    Tcl_Size offset;
    Tcl_LibraryInitProc *initProc;
    const char *fullFileName, *prefix;
    Tcl_LoadHandle loadHandle;
    Tcl_UniChar ch = 0;
    size_t len;
    int flags = 0;







|







133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;
    LoadedLibrary *libraryPtr, *defaultPtr;
    Tcl_DString pfx, tmp, initName, safeInitName;
    Tcl_DString unloadName, safeUnloadName;
    int code;
    Tcl_Size offset;
    Tcl_LibraryInitProc *initProc;
    const char *fullFileName, *prefix;
    Tcl_LoadHandle loadHandle;
    Tcl_UniChar ch = 0;
    size_t len;
    int flags = 0;
228
229
230
231
232
233
234

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
     */

    Tcl_MutexLock(&libraryMutex);

    defaultPtr = NULL;
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
	    libraryPtr = libraryPtr->nextPtr) {

	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}
	TclDStringClear(&pfx);

	filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
	if (filesMatch && (namesMatch || (prefix == NULL))) {
	    break;
	}







>

|





|
|
<
<
<
<







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244




245
246
247
248
249
250
251
     */

    Tcl_MutexLock(&libraryMutex);

    defaultPtr = NULL;
    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
	    libraryPtr = libraryPtr->nextPtr) {
	bool namesMatch, filesMatch;
	if (prefix == NULL) {
	    namesMatch = false;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    namesMatch = (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0);




	}
	TclDStringClear(&pfx);

	filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
	if (filesMatch && (namesMatch || (prefix == NULL))) {
	    break;
	}
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;		/* Which interpreter to unload from. */
    LoadedLibrary *libraryPtr;
    Tcl_DString pfx, tmp;
    InterpLibrary *ipFirstPtr, *ipPtr;
    int i, code, complain = 1, keepLibrary = 0;

    const char *fullFileName = "";
    const char *prefix;
    static const char *const options[] = {
	"-nocomplain", "-keeplibrary", "--", NULL
    };
    enum unloadOptionsEnum {
	UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST







|
>







552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Interp *target;		/* Which interpreter to unload from. */
    LoadedLibrary *libraryPtr;
    Tcl_DString pfx, tmp;
    InterpLibrary *ipFirstPtr, *ipPtr;
    int i, code;
    bool complain = true, keepLibrary = false;
    const char *fullFileName = "";
    const char *prefix;
    static const char *const options[] = {
	"-nocomplain", "-keeplibrary", "--", NULL
    };
    enum unloadOptionsEnum {
	UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605

		Tcl_ResetResult(interp);
		break;
	    }
	}
	switch (index) {
	case UNLOAD_NOCOMPLAIN:		/* -nocomplain */
	    complain = 0;
	    break;
	case UNLOAD_KEEPLIB:		/* -keeplibrary */
	    keepLibrary = 1;
	    break;
	case UNLOAD_LAST:		/* -- */
	    i++;
	    goto endOfForLoop;
	default:
	    TCL_UNREACHABLE();
	}







|


|







586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603

		Tcl_ResetResult(interp);
		break;
	    }
	}
	switch (index) {
	case UNLOAD_NOCOMPLAIN:		/* -nocomplain */
	    complain = false;
	    break;
	case UNLOAD_KEEPLIB:		/* -keeplibrary */
	    keepLibrary = true;
	    break;
	case UNLOAD_LAST:		/* -- */
	    i++;
	    goto endOfForLoop;
	default:
	    TCL_UNREACHABLE();
	}
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
     *  - Its prefix matches, the file name was specified as empty, and there is
     *	  no statically loaded library with the same prefix.
     */

    Tcl_MutexLock(&libraryMutex);

    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	int namesMatch, filesMatch;

	if (prefix == NULL) {
	    namesMatch = 0;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    if (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0) {
		namesMatch = 1;
	    } else {
		namesMatch = 0;
	    }
	}
	TclDStringClear(&pfx);

	filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
	if (filesMatch && (namesMatch || (prefix == NULL))) {
	    break;
	}







|


|





|
|
<
<
<
<







653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670




671
672
673
674
675
676
677
     *  - Its prefix matches, the file name was specified as empty, and there is
     *	  no statically loaded library with the same prefix.
     */

    Tcl_MutexLock(&libraryMutex);

    for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
	bool namesMatch, filesMatch;

	if (prefix == NULL) {
	    namesMatch = false;
	} else {
	    TclDStringClear(&pfx);
	    Tcl_DStringAppend(&pfx, prefix, -1);
	    TclDStringClear(&tmp);
	    Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
	    namesMatch = (strcmp(Tcl_DStringValue(&tmp),
		    Tcl_DStringValue(&pfx)) == 0);




	}
	TclDStringClear(&pfx);

	filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
	if (filesMatch && (namesMatch || (prefix == NULL))) {
	    break;
	}
735
736
737
738
739
740
741
742

743
744
745
746
747
748
749
		"file \"%s\" has never been loaded in this interpreter",
		fullFileName);
	TclSetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED");
	code = TCL_ERROR;
	goto done;
    }

    code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);


  done:
    Tcl_DStringFree(&pfx);
    Tcl_DStringFree(&tmp);
    if (!complain && (code != TCL_OK)) {
	code = TCL_OK;
	Tcl_ResetResult(interp);







|
>







729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
		"file \"%s\" has never been loaded in this interpreter",
		fullFileName);
	TclSetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED");
	code = TCL_ERROR;
	goto done;
    }

    code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName,
	    false);

  done:
    Tcl_DStringFree(&pfx);
    Tcl_DStringFree(&tmp);
    if (!complain && (code != TCL_OK)) {
	code = TCL_OK;
	Tcl_ResetResult(interp);
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
 *----------------------------------------------------------------------
 */
static int
UnloadLibrary(
    Tcl_Interp *interp,
    Tcl_Interp *target,
    LoadedLibrary *libraryPtr,
    int keepLibrary,
    const char *fullFileName,
    int interpExiting)
{
    int code;
    InterpLibrary *ipFirstPtr, *ipPtr;
    LoadedLibrary *iterLibraryPtr;
    int trustedRefCount = -1, safeRefCount = -1;
    Tcl_LibraryUnloadProc *unloadProc = NULL;








|

|







763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
 *----------------------------------------------------------------------
 */
static int
UnloadLibrary(
    Tcl_Interp *interp,
    Tcl_Interp *target,
    LoadedLibrary *libraryPtr,
    bool keepLibrary,
    const char *fullFileName,
    bool interpExiting)
{
    int code;
    InterpLibrary *ipFirstPtr, *ipPtr;
    LoadedLibrary *iterLibraryPtr;
    int trustedRefCount = -1, safeRefCount = -1;
    Tcl_LibraryUnloadProc *unloadProc = NULL;

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
    Tcl_Interp *interp)
{
    InterpLibrary *ipPtr = (InterpLibrary *)clientData, *nextPtr;
    LoadedLibrary *libraryPtr;

    while (ipPtr) {
	libraryPtr = ipPtr->libraryPtr;
	UnloadLibrary(interp, interp, libraryPtr, 0, "", 1);
	/* UnloadLibrary doesn't free it by interp delete, so do it here and
	 * repeat for next. */
	nextPtr = ipPtr->nextPtr;
	Tcl_Free(ipPtr);
	ipPtr = nextPtr;
    }
}







|







1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
    Tcl_Interp *interp)
{
    InterpLibrary *ipPtr = (InterpLibrary *)clientData, *nextPtr;
    LoadedLibrary *libraryPtr;

    while (ipPtr) {
	libraryPtr = ipPtr->libraryPtr;
	UnloadLibrary(interp, interp, libraryPtr, false, "", true);
	/* UnloadLibrary doesn't free it by interp delete, so do it here and
	 * repeat for next. */
	nextPtr = ipPtr->nextPtr;
	Tcl_Free(ipPtr);
	ipPtr = nextPtr;
    }
}
Changes to generic/tclMain.c.
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
 *
 * Results:
 *	A boolean.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE int
TclFullFinalizationRequested(void)
{
#ifdef PURIFY
    return 1;
#else
    const char *fin;
    Tcl_DString ds;
    int finalize = 0;

    fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
    finalize = ((fin != NULL) && strcmp(fin, "0"));
    if (fin != NULL) {
	Tcl_DStringFree(&ds);
    }
    return finalize;







|



|



|







690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
 *
 * Results:
 *	A boolean.
 *
 *----------------------------------------------------------------------
 */

MODULE_SCOPE bool
TclFullFinalizationRequested(void)
{
#ifdef PURIFY
    return true;
#else
    const char *fin;
    Tcl_DString ds;
    bool finalize = false;

    fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
    finalize = ((fin != NULL) && strcmp(fin, "0"));
    if (fin != NULL) {
	Tcl_DStringFree(&ds);
    }
    return finalize;
Changes to generic/tclNamesp.c.
1169
1170
1171
1172
1173
1174
1175
1176

1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187

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

int

TclNamespaceDeleted(
    Namespace *nsPtr)
{
    return (nsPtr->flags & NS_DYING) ? 1 : 0;
}

void
TclDeleteNamespaceChildren(
    Namespace *nsPtr)		/* Namespace whose children to delete */
{
    Tcl_Interp *interp = nsPtr->interp;







<
>



|







1169
1170
1171
1172
1173
1174
1175

1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187

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


bool
TclNamespaceDeleted(
    Namespace *nsPtr)
{
    return (nsPtr->flags & NS_DYING) ? true : false;
}

void
TclDeleteNamespaceChildren(
    Namespace *nsPtr)		/* Namespace whose children to delete */
{
    Tcl_Interp *interp = nsPtr->interp;
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
     * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
     * f97d4ee020]) copy to a temporary array and then delete all those
     * namespaces.
     *
     * Important: leave the hash table itself still live.
     */

    int unchecked = (NumChildEntries(nsPtr) > 0);
    while (NumChildEntries(nsPtr) > 0 && unchecked) {
	size_t length = NumChildEntries(nsPtr);
	Namespace **children = (Namespace **)
		TclStackAlloc(interp, sizeof(Namespace *) * length);

	size_t i = 0;
	for (entryPtr = FirstChildEntry(nsPtr, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
	    children[i] = (Namespace *) Tcl_GetHashValue(entryPtr);
	    children[i]->refCount++;
	    i++;
	}
	unchecked = 0;
	for (i = 0 ; i < length ; i++) {
	    if (!(children[i]->flags & NS_DYING)) {
		unchecked = 1;
		Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
		TclNsDecrRefCount(children[i]);
	    }
	}
	TclStackFree(interp, children);
    }
}







|













|


|







1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
     * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
     * f97d4ee020]) copy to a temporary array and then delete all those
     * namespaces.
     *
     * Important: leave the hash table itself still live.
     */

    bool unchecked = (NumChildEntries(nsPtr) > 0);
    while (NumChildEntries(nsPtr) > 0 && unchecked) {
	size_t length = NumChildEntries(nsPtr);
	Namespace **children = (Namespace **)
		TclStackAlloc(interp, sizeof(Namespace *) * length);

	size_t i = 0;
	for (entryPtr = FirstChildEntry(nsPtr, &search);
		entryPtr != NULL;
		entryPtr = Tcl_NextHashEntry(&search)) {
	    children[i] = (Namespace *) Tcl_GetHashValue(entryPtr);
	    children[i]->refCount++;
	    i++;
	}
	unchecked = false;
	for (i = 0 ; i < length ; i++) {
	    if (!(children[i]->flags & NS_DYING)) {
		unchecked = true;
		Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
		TclNsDecrRefCount(children[i]);
	    }
	}
	TclStackFree(interp, children);
    }
}
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
	 * such that there is a identically-named sequence of child namespaces
	 * starting from ::. shadowNsPtr will be the tail of this sequence, or
	 * the deepest namespace under :: that might contain a command now
	 * shadowed by cmdName. We check below if shadowNsPtr actually
	 * contains a command cmdName.
	 */

	int found = 1;
	shadowNsPtr = globalNsPtr;

	for (int i = trailFront;  i >= 0;  i--) {
	    trailNsPtr = trailPtr[i];
	    hPtr = FindChildEntry(shadowNsPtr, trailNsPtr->name);
	    if (hPtr != NULL) {
		shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
	    } else {
		found = 0;
		break;
	    }
	}

	/*
	 * If shadowNsPtr contains a command named cmdName, we invalidate all
	 * of the command refs cached in nsPtr. As a boundary case,







|








|







2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
	 * such that there is a identically-named sequence of child namespaces
	 * starting from ::. shadowNsPtr will be the tail of this sequence, or
	 * the deepest namespace under :: that might contain a command now
	 * shadowed by cmdName. We check below if shadowNsPtr actually
	 * contains a command cmdName.
	 */

	bool found = true;
	shadowNsPtr = globalNsPtr;

	for (int i = trailFront;  i >= 0;  i--) {
	    trailNsPtr = trailPtr[i];
	    hPtr = FindChildEntry(shadowNsPtr, trailNsPtr->name);
	    if (hPtr != NULL) {
		shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
	    } else {
		found = false;
		break;
	    }
	}

	/*
	 * If shadowNsPtr contains a command named cmdName, we invalidate all
	 * of the command refs cached in nsPtr. As a boundary case,
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
static int
NamespaceImportCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int allowOverwrite = 0;

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
	return TCL_ERROR;
    }

    /*
     * Skip over the optional "-force" as the first argument.
     */

    int firstArg = 1;
    if (firstArg < objc) {
	const char *string = TclGetString(objv[firstArg]);
	if ((*string == '-') && (strcmp(string, "-force") == 0)) {
	    allowOverwrite = 1;
	    firstArg++;
	}
    } else {
	/*
	 * When objc == 1, command is just [namespace import]. Introspection
	 * form to return list of imported commands.
	 */







|














|







3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
static int
NamespaceImportCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    bool allowOverwrite = false;

    if (objc < 1) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
	return TCL_ERROR;
    }

    /*
     * Skip over the optional "-force" as the first argument.
     */

    int firstArg = 1;
    if (firstArg < objc) {
	const char *string = TclGetString(objv[firstArg]);
	if ((*string == '-') && (strcmp(string, "-force") == 0)) {
	    allowOverwrite = true;
	    firstArg++;
	}
    } else {
	/*
	 * When objc == 1, command is just [namespace import]. Introspection
	 * form to return list of imported commands.
	 */
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = 0;
	TclListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);







|







5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = false;
	TclListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = 0;
	TclListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);







|







5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
	Tcl_DecrRefCount(iPtr->errorStack);
	Tcl_IncrRefCount(newObj);
	iPtr->errorStack = newObj;
    }
    if (iPtr->resetErrorStack) {
	Tcl_Size len;

	iPtr->resetErrorStack = false;
	TclListObjLength(interp, iPtr->errorStack, &len);

	/*
	 * Reset while keeping the list internalrep as much as possible.
	 */

	Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
Changes to generic/tclNotify.c.
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
				 * if none. */
    Tcl_Size eventCount;	/* Number of entries, but refer to comments in
				 * Tcl_ServiceEvent(). */
    Tcl_Mutex queueMutex;	/* Mutex to protect access to the previous
				 * four fields. */
    int serviceMode;		/* One of TCL_SERVICE_NONE or
				 * TCL_SERVICE_ALL. */
    int blockTimeSet;		/* 0 means there is no maximum block time:
				 * block forever. */
    Tcl_Time blockTime;		/* If blockTimeSet is 1, gives the maximum
				 * elapsed time for the next block. */
    int inTraversal;		/* 1 if Tcl_SetMaxBlockTime is being called
				 * during an event source traversal. */
    int initialized;		/* 1 if notifier has been initialized. */
    EventSource *firstEventSourcePtr;
				/* Pointer to first event source in list of
				 * event sources for this thread. */
    Tcl_ThreadId threadId;	/* Thread that owns this notifier instance. */
    void *clientData;		/* Opaque handle for platform specific
				 * notifier. */
    ThreadSpecificData *nextPtr;/* Next notifier in global list of notifiers.







|



|

|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
				 * if none. */
    Tcl_Size eventCount;	/* Number of entries, but refer to comments in
				 * Tcl_ServiceEvent(). */
    Tcl_Mutex queueMutex;	/* Mutex to protect access to the previous
				 * four fields. */
    int serviceMode;		/* One of TCL_SERVICE_NONE or
				 * TCL_SERVICE_ALL. */
    bool blockTimeSet;		/* false means there is no maximum block time:
				 * block forever. */
    Tcl_Time blockTime;		/* If blockTimeSet is 1, gives the maximum
				 * elapsed time for the next block. */
    bool inTraversal;		/* true if Tcl_SetMaxBlockTime is being called
				 * during an event source traversal. */
    bool initialized;		/* true if notifier has been initialized. */
    EventSource *firstEventSourcePtr;
				/* Pointer to first event source in list of
				 * event sources for this thread. */
    Tcl_ThreadId threadId;	/* Thread that owns this notifier instance. */
    void *clientData;		/* Opaque handle for platform specific
				 * notifier. */
    ThreadSpecificData *nextPtr;/* Next notifier in global list of notifiers.
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
	/*
	 * Notifier not yet initialized in this thread.
	 */

	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->threadId = threadId;
	tsdPtr->clientData = Tcl_InitNotifier();
	tsdPtr->initialized = 1;
	tsdPtr->nextPtr = firstNotifierPtr;
	firstNotifierPtr = tsdPtr;
    }
    Tcl_MutexUnlock(&listLock);
}

/*







|







132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
	/*
	 * Notifier not yet initialized in this thread.
	 */

	tsdPtr = TCL_TSD_INIT(&dataKey);
	tsdPtr->threadId = threadId;
	tsdPtr->clientData = Tcl_InitNotifier();
	tsdPtr->initialized = true;
	tsdPtr->nextPtr = firstNotifierPtr;
	firstNotifierPtr = tsdPtr;
    }
    Tcl_MutexUnlock(&listLock);
}

/*
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
    for (ThreadSpecificData **prevPtrPtr = &firstNotifierPtr; *prevPtrPtr;
	    prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}
    }
    tsdPtr->initialized = 0;

    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *







|







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
    for (ThreadSpecificData **prevPtrPtr = &firstNotifierPtr; *prevPtrPtr;
	    prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}
    }
    tsdPtr->initialized = false;

    Tcl_MutexUnlock(&listLock);
}

/*
 *----------------------------------------------------------------------
 *
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
				 * must have been allocated the caller with
				 * malloc (Tcl_Alloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */
    int position)		/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
				 * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
    int wasEmpty = 0;

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    if ((position & 3) == TCL_QUEUE_TAIL) {
	/*
	 * Append the event on the end of the queue.
	 */








|







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
				 * must have been allocated the caller with
				 * malloc (Tcl_Alloc), and it becomes the
				 * property of the event queue. It will be
				 * freed after the event has been handled. */
    int position)		/* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
				 * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
    bool wasEmpty = false;

    Tcl_MutexLock(&(tsdPtr->queueMutex));
    if ((position & 3) == TCL_QUEUE_TAIL) {
	/*
	 * Append the event on the end of the queue.
	 */

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
				 * flags defined elsewhere. Events not
				 * matching this will be skipped for
				 * processing later. */
{
    Tcl_EventProc *proc;
    Tcl_Size eventCount;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;

    /*
     * Asynchronous event handlers are considered to be the highest priority
     * events, and so must be invoked before we process events on the event
     * queue.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke(NULL, 0);
	return 1;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */

    if ((flags & TCL_ALL_EVENTS) == 0) {







<









|







647
648
649
650
651
652
653

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
				 * flags defined elsewhere. Events not
				 * matching this will be skipped for
				 * processing later. */
{
    Tcl_EventProc *proc;
    Tcl_Size eventCount;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);


    /*
     * Asynchronous event handlers are considered to be the highest priority
     * events, and so must be invoked before we process events on the event
     * queue.
     */

    if (Tcl_AsyncReady()) {
	(void) Tcl_AsyncInvoke(NULL, 0);
	return true;
    }

    /*
     * No event flags is equivalent to TCL_ALL_EVENTS.
     */

    if ((flags & TCL_ALL_EVENTS) == 0) {
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
	 * Tcl_ThreadQueueEvent() to perform optional wakeups.
	 * On exit of the next level, the eventCount is readjusted.
	 */

	eventCount = tsdPtr->eventCount;
	tsdPtr->eventCount = 0;
	Tcl_MutexUnlock(&tsdPtr->queueMutex);
	result = proc(evPtr, flags);
	Tcl_MutexLock(&tsdPtr->queueMutex);
	tsdPtr->eventCount += eventCount;

	if (result) {
	    /*
	     * The event was processed, so remove it from the queue.
	     */







|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
	 * Tcl_ThreadQueueEvent() to perform optional wakeups.
	 * On exit of the next level, the eventCount is readjusted.
	 */

	eventCount = tsdPtr->eventCount;
	tsdPtr->eventCount = 0;
	Tcl_MutexUnlock(&tsdPtr->queueMutex);
	int result = proc(evPtr, flags);
	Tcl_MutexLock(&tsdPtr->queueMutex);
	tsdPtr->eventCount += eventCount;

	if (result) {
	    /*
	     * The event was processed, so remove it from the queue.
	     */
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
		}
	    }
	    if (evPtr) {
		Tcl_Free(evPtr);
		tsdPtr->eventCount--;
	    }
	    Tcl_MutexUnlock(&tsdPtr->queueMutex);
	    return 1;
	} else {
	    /*
	     * The event wasn't actually handled, so we have to restore the
	     * proc field to allow the event to be attempted again.
	     */

	    evPtr->proc = proc;
	}
    }
    Tcl_MutexUnlock(&tsdPtr->queueMutex);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetServiceMode --
 *







|










|







753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
		}
	    }
	    if (evPtr) {
		Tcl_Free(evPtr);
		tsdPtr->eventCount--;
	    }
	    Tcl_MutexUnlock(&tsdPtr->queueMutex);
	    return true;
	} else {
	    /*
	     * The event wasn't actually handled, so we have to restore the
	     * proc field to allow the event to be attempted again.
	     */

	    evPtr->proc = proc;
	}
    }
    Tcl_MutexUnlock(&tsdPtr->queueMutex);
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetServiceMode --
 *
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
	    || ((timePtr->sec == tsdPtr->blockTime.sec)
	    && (timePtr->usec < tsdPtr->blockTime.usec))) {
	tsdPtr->blockTime = *timePtr;
	tsdPtr->blockTimeSet = 1;
    }

    /*
     * If we are called outside an event source traversal, set the timeout
     * immediately.
     */








|







851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
	    || ((timePtr->sec == tsdPtr->blockTime.sec)
	    && (timePtr->usec < tsdPtr->blockTime.usec))) {
	tsdPtr->blockTime = *timePtr;
	tsdPtr->blockTimeSet = true;
    }

    /*
     * If we are called outside an event source traversal, set the timeout
     * immediately.
     */

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
985
986
987
988
989
990
	 * If TCL_DONT_WAIT is set, be sure to poll rather than blocking,
	 * otherwise reset the block time to infinity.
	 */

	if (flags & TCL_DONT_WAIT) {
	    tsdPtr->blockTime.sec = 0;
	    tsdPtr->blockTime.usec = 0;
	    tsdPtr->blockTimeSet = 1;
	} else {
	    tsdPtr->blockTimeSet = 0;
	}

	/*
	 * Set up all the event sources for new events. This will cause the
	 * block time to be updated if necessary.
	 */

	tsdPtr->inTraversal = 1;
	for (EventSource *sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr;
		sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->setupProc) {
		sourcePtr->setupProc(sourcePtr->clientData, flags);
	    }
	}
	tsdPtr->inTraversal = 0;

	Tcl_Time *timePtr;
	if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
	    timePtr = &tsdPtr->blockTime;
	} else {
	    timePtr = NULL;
	}







|

|







|






|







958
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
985
986
987
988
989
	 * If TCL_DONT_WAIT is set, be sure to poll rather than blocking,
	 * otherwise reset the block time to infinity.
	 */

	if (flags & TCL_DONT_WAIT) {
	    tsdPtr->blockTime.sec = 0;
	    tsdPtr->blockTime.usec = 0;
	    tsdPtr->blockTimeSet = true;
	} else {
	    tsdPtr->blockTimeSet = false;
	}

	/*
	 * Set up all the event sources for new events. This will cause the
	 * block time to be updated if necessary.
	 */

	tsdPtr->inTraversal = true;
	for (EventSource *sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr;
		sourcePtr = sourcePtr->nextPtr) {
	    if (sourcePtr->setupProc) {
		sourcePtr->setupProc(sourcePtr->clientData, flags);
	    }
	}
	tsdPtr->inTraversal = false;

	Tcl_Time *timePtr;
	if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
	    timePtr = &tsdPtr->blockTime;
	} else {
	    timePtr = NULL;
	}
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121

    /*
     * Make a single pass through all event sources, queued events, and idle
     * handlers. Note that we wait to update the notifier timer until the end
     * so we can avoid multiple changes.
     */

    tsdPtr->inTraversal = 1;
    tsdPtr->blockTimeSet = 0;

    for (EventSource *sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr;
	    sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->setupProc) {
	    sourcePtr->setupProc(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }







|
|







1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120

    /*
     * Make a single pass through all event sources, queued events, and idle
     * handlers. Note that we wait to update the notifier timer until the end
     * so we can avoid multiple changes.
     */

    tsdPtr->inTraversal = true;
    tsdPtr->blockTimeSet = false;

    for (EventSource *sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr;
	    sourcePtr = sourcePtr->nextPtr) {
	if (sourcePtr->setupProc) {
	    sourcePtr->setupProc(sourcePtr->clientData, TCL_ALL_EVENTS);
	}
    }
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
    }

    if (!tsdPtr->blockTimeSet) {
	Tcl_SetTimer(NULL);
    } else {
	Tcl_SetTimer(&tsdPtr->blockTime);
    }
    tsdPtr->inTraversal = 0;
    tsdPtr->serviceMode = TCL_SERVICE_ALL;
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|







1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
    }

    if (!tsdPtr->blockTimeSet) {
	Tcl_SetTimer(NULL);
    } else {
	Tcl_SetTimer(&tsdPtr->blockTime);
    }
    tsdPtr->inTraversal = false;
    tsdPtr->serviceMode = TCL_SERVICE_ALL;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclOO.c.
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
 */

#define DCM(name,visibility,proc) \
    {name,visibility,\
	{TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}

static const DeclaredClassMethod objMethods[] = {
    DCM("destroy", 1,	TclOO_Object_Destroy),
    DCM("eval", 0,	TclOO_Object_Eval),
    DCM("unknown", 0,	TclOO_Object_Unknown),
    DCM("variable", 0,	TclOO_Object_LinkVar),
    DCM("varname", 0,	TclOO_Object_VarName),
    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
}, clsMethods[] = {
    DCM("create", 1,	TclOO_Class_Create),
    DCM("new", 1,	TclOO_Class_New),
    DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
}, cfgMethods[] = {
    DCM("configure", 1, TclOO_Configurable_Configure),
    {NULL, 0, {0, NULL, NULL, NULL, NULL}}
};

/*
 * And for the oo::class constructor...
 */

static const Tcl_MethodType classConstructor = {







|
|
|
|
|
|

|
|
|
|

|
|







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
 */

#define DCM(name,visibility,proc) \
    {name,visibility,\
	{TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}

static const DeclaredClassMethod objMethods[] = {
    DCM("destroy", true,	TclOO_Object_Destroy),
    DCM("eval", false,		TclOO_Object_Eval),
    DCM("unknown", false,	TclOO_Object_Unknown),
    DCM("variable", false,	TclOO_Object_LinkVar),
    DCM("varname", false,	TclOO_Object_VarName),
    {NULL, false, {0, NULL, NULL, NULL, NULL}}
}, clsMethods[] = {
    DCM("create", true,		TclOO_Class_Create),
    DCM("new", true,		TclOO_Class_New),
    DCM("createWithNamespace", false, TclOO_Class_CreateNs),
    {NULL, false, {0, NULL, NULL, NULL, NULL}}
}, cfgMethods[] = {
    DCM("configure", true,	TclOO_Configurable_Configure),
    {NULL, false, {0, NULL, NULL, NULL, NULL}}
};

/*
 * And for the oo::class constructor...
 */

static const Tcl_MethodType classConstructor = {
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371

1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389

/*
 * ----------------------------------------------------------------------
 *
 * TclOODecrRefCount --
 *
 *	Decrement the refcount of an object and deallocate storage then object
 *	is no longer referenced.  Returns 1 if storage was deallocated, and 0
 *	otherwise.
 *
 * ----------------------------------------------------------------------
 */

int

TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- <= 1) {
	if (oPtr->classPtr != NULL) {
	    Tcl_Free(oPtr->classPtr);
	}
	Tcl_Free(oPtr);
	return 1;
    }
    return 0;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectDestroyed --
 *







|
|




<
>








|

|







1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370

1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389

/*
 * ----------------------------------------------------------------------
 *
 * TclOODecrRefCount --
 *
 *	Decrement the refcount of an object and deallocate storage then object
 *	is no longer referenced.  Returns true if storage was deallocated, and
 *	false otherwise.
 *
 * ----------------------------------------------------------------------
 */


bool
TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- <= 1) {
	if (oPtr->classPtr != NULL) {
	    Tcl_Free(oPtr->classPtr);
	}
	Tcl_Free(oPtr);
	return true;
    }
    return false;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectDestroyed --
 *
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
 *
 *	Utility function that tests whether a class is a subclass (whether
 *	directly or indirectly) of another class.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOIsReachable(
    Class *targetPtr,
    Class *startPtr)
{
    Class *superPtr;

  tailRecurse:
    if (startPtr == targetPtr) {
	return 1;
    }
    if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
	startPtr = startPtr->superclasses.list[0];
	goto tailRecurse;
    }
    FOREACH(superPtr, startPtr->superclasses) {
	if (TclOOIsReachable(targetPtr, superPtr)) {
	    return 1;
	}
    }
    FOREACH(superPtr, startPtr->mixins) {
	if (TclOOIsReachable(targetPtr, superPtr)) {
	    return 1;
	}
    }
    return 0;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectName, Tcl_GetObjectName --
 *







|








|







|




|


|







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
 *
 *	Utility function that tests whether a class is a subclass (whether
 *	directly or indirectly) of another class.
 *
 * ----------------------------------------------------------------------
 */

int // bool, but not for backward compatibility
TclOOIsReachable(
    Class *targetPtr,
    Class *startPtr)
{
    Class *superPtr;

  tailRecurse:
    if (startPtr == targetPtr) {
	return true;
    }
    if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
	startPtr = startPtr->superclasses.list[0];
	goto tailRecurse;
    }
    FOREACH(superPtr, startPtr->superclasses) {
	if (TclOOIsReachable(targetPtr, superPtr)) {
	    return true;
	}
    }
    FOREACH(superPtr, startPtr->mixins) {
	if (TclOOIsReachable(targetPtr, superPtr)) {
	    return true;
	}
    }
    return false;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectName, Tcl_GetObjectName --
 *
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
}

int
Tcl_ObjectContextIsFiltering(
    Tcl_ObjectContext context)
{
    CallContext *contextPtr = (CallContext *) context;
    return contextPtr->callPtr->chain[contextPtr->index].isFilter;
}

Tcl_Object
Tcl_ObjectContextObject(
    Tcl_ObjectContext context)
{
    return (Tcl_Object) ((CallContext *) context)->oPtr;







|







3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
}

int
Tcl_ObjectContextIsFiltering(
    Tcl_ObjectContext context)
{
    CallContext *contextPtr = (CallContext *) context;
    return (int) contextPtr->callPtr->chain[contextPtr->index].isFilter;
}

Tcl_Object
Tcl_ObjectContextObject(
    Tcl_ObjectContext context)
{
    return (Tcl_Object) ((CallContext *) context)->oPtr;
Changes to generic/tclOOBasic.c.
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
			varName = pvPtr->fullNameObj;
			break;
		    }
		}
	    } else if (mPtr->declaringClassPtr &&
		    mPtr->declaringClassPtr->privateVariables.num) {
		Class *clsPtr = mPtr->declaringClassPtr;
		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);

		if (!isInstance) {
		    Class *mixinCls;
		    FOREACH(mixinCls, oPtr->mixins) {
			if (TclOOIsReachable(clsPtr, mixinCls)) {
			    isInstance = 1;
			    break;
			}
		    }
		}
		if (isInstance) {
		    PrivateVariableMapping *pvPtr;
		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {







|





|







776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
			varName = pvPtr->fullNameObj;
			break;
		    }
		}
	    } else if (mPtr->declaringClassPtr &&
		    mPtr->declaringClassPtr->privateVariables.num) {
		Class *clsPtr = mPtr->declaringClassPtr;
		bool isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);

		if (!isInstance) {
		    Class *mixinCls;
		    FOREACH(mixinCls, oPtr->mixins) {
			if (TclOOIsReachable(clsPtr, mixinCls)) {
			    isInstance = true;
			    break;
			}
		    }
		}
		if (isInstance) {
		    PrivateVariableMapping *pvPtr;
		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
Changes to generic/tclOOCall.c.
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
static inline void	AddDefinitionNamespaceToChain(Class *const definerCls,
			    Tcl_Obj *const namespaceName,
			    DefineChain *const definePtr, int flags);
static inline void	AddMethodToCallChain(Method *const mPtr,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters,
			    Class *const filterDecl, int flags);
static inline int	AddInstancePrivateToCallContext(Object *const oPtr,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr, int flags);
static inline void	AddStandardMethodName(int flags, Tcl_Obj *namePtr,
			    Method *mPtr, Tcl_HashTable *namesPtr);
static inline void	AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
			    Tcl_HashTable *namesPtr);
static inline int	AddSimpleChainToCallContext(Object *const oPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		AddPrivatesFromClassChainToCallContext(Class *classPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static void		AddSimpleClassDefineNamespaces(Class *classPtr,
			    DefineChain *const definePtr, int flags);
static inline void	AddSimpleDefineNamespaces(Object *const oPtr,
			    DefineChain *const definePtr, int flags);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc	FinalizeMethodRefs;
static void		FreeMethodNameRep(Tcl_Obj *objPtr);
static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
			    int flags, int reuseMask);
static Tcl_NRPostProc	ResetFilterFlags;
static Tcl_NRPostProc	SetFilterFlags;
static size_t		SortMethodNames(Tcl_HashTable *namesPtr, int flags,
			    const char ***stringsPtr);
static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);








|






|





|





|












|







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
static inline void	AddDefinitionNamespaceToChain(Class *const definerCls,
			    Tcl_Obj *const namespaceName,
			    DefineChain *const definePtr, int flags);
static inline void	AddMethodToCallChain(Method *const mPtr,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters,
			    Class *const filterDecl, int flags);
static inline bool	AddInstancePrivateToCallContext(Object *const oPtr,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr, int flags);
static inline void	AddStandardMethodName(int flags, Tcl_Obj *namePtr,
			    Method *mPtr, Tcl_HashTable *namesPtr);
static inline void	AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
			    Tcl_HashTable *namesPtr);
static inline bool	AddSimpleChainToCallContext(Object *const oPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static bool		AddPrivatesFromClassChainToCallContext(Class *classPtr,
			    Class *const contextCls,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static bool		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static void		AddSimpleClassDefineNamespaces(Class *classPtr,
			    DefineChain *const definePtr, int flags);
static inline void	AddSimpleDefineNamespaces(Object *const oPtr,
			    DefineChain *const definePtr, int flags);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc	FinalizeMethodRefs;
static void		FreeMethodNameRep(Tcl_Obj *objPtr);
static inline bool	IsStillValid(CallChain *callPtr, Object *oPtr,
			    int flags, int reuseMask);
static Tcl_NRPostProc	ResetFilterFlags;
static Tcl_NRPostProc	SetFilterFlags;
static size_t		SortMethodNames(Tcl_HashTable *namesPtr, int flags,
			    const char ***stringsPtr);
static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
				 * commands, variables) depending on method
				 * implementation. */
    int objc,			/* The number of arguments. */
    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
{
    CallContext *const contextPtr = (CallContext *) clientData;
    Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const int isFilter =
	    contextPtr->callPtr->chain[contextPtr->index].isFilter;

    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */







|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
				 * commands, variables) depending on method
				 * implementation. */
    int objc,			/* The number of arguments. */
    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
{
    CallContext *const contextPtr = (CallContext *) clientData;
    Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const bool isFilter =
	    contextPtr->callPtr->chain[contextPtr->index].isFilter;

    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
     */

    while (1) {
	Tcl_Obj *namePtr;
	Method *mPtr;
	int isNew;

	(void) Tcl_CreateHashEntry(examinedClassesPtr, clsPtr,
		&isNew);
	if (!isNew) {
	    break;
	}

	if (clsPtr->mixins.num != 0) {
	    Class *mixinPtr;








|
<







727
728
729
730
731
732
733
734

735
736
737
738
739
740
741
     */

    while (1) {
	Tcl_Obj *namePtr;
	Method *mPtr;
	int isNew;

	(void) Tcl_CreateHashEntry(examinedClassesPtr, clsPtr, &isNew);

	if (!isNew) {
	    break;
	}

	if (clsPtr->mixins.num != 0) {
	    Class *mixinPtr;

798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
    int flags,
    Tcl_Obj *namePtr,
    Method *mPtr,
    Tcl_HashTable *namesPtr)
{
    if (!IS_PRIVATE(mPtr)) {
	int isNew;
	Tcl_HashEntry *hPtr =
		Tcl_CreateHashEntry(namesPtr, namePtr, &isNew);

	if (isNew) {
	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
		    ? IN_LIST : 0;

	    isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));







<
|







797
798
799
800
801
802
803

804
805
806
807
808
809
810
811
    int flags,
    Tcl_Obj *namePtr,
    Method *mPtr,
    Tcl_HashTable *namesPtr)
{
    if (!IS_PRIVATE(mPtr)) {
	int isNew;

	Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, &isNew);

	if (isNew) {
	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
		    ? IN_LIST : 0;

	    isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
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
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
 *	context is a TclOO method declared by an object that is the same as
 *	the current object. Returns true iff a private method was actually
 *	found and added to the call chain (as this suppresses caching).
 *
 * ----------------------------------------------------------------------
 */

static inline int
AddInstancePrivateToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    int flags)			/* What sort of call chain are we building. */
{
    Tcl_HashEntry *hPtr;
    Method *mPtr;
    int donePrivate = 0;

    if (oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
	if (hPtr != NULL) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
		donePrivate = 1;
	    }
	}
    }
    return donePrivate;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleChainToCallContext --
 *
 *	The core of the call-chain construction engine, this handles calling a
 *	particular method on a particular object. Note that filters and
 *	unknown handling are already handled by the logic that uses this
 *	function. Returns true if a private method was one of those found.
 *
 * ----------------------------------------------------------------------
 */

static inline int
AddSimpleChainToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. [TIP 500] */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    int foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);

	if (hPtr != NULL) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (!IS_PRIVATE(mPtr)) {
		if (WANT_PUBLIC(flags)) {
		    if (!IS_PUBLIC(mPtr)) {
			blockedUnexported = 1;
		    } else {
			flags |= DEFINITE_PUBLIC;
		    }
		} else {
		    flags |= DEFINITE_PROTECTED;
		}
	    }







|









|







|



















|

















|











|







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
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
 *	context is a TclOO method declared by an object that is the same as
 *	the current object. Returns true iff a private method was actually
 *	found and added to the call chain (as this suppresses caching).
 *
 * ----------------------------------------------------------------------
 */

static inline bool
AddInstancePrivateToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    int flags)			/* What sort of call chain are we building. */
{
    Tcl_HashEntry *hPtr;
    Method *mPtr;
    bool donePrivate = false;

    if (oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
	if (hPtr != NULL) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
		donePrivate = true;
	    }
	}
    }
    return donePrivate;
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleChainToCallContext --
 *
 *	The core of the call-chain construction engine, this handles calling a
 *	particular method on a particular object. Note that filters and
 *	unknown handling are already handled by the logic that uses this
 *	function. Returns true if a private method was one of those found.
 *
 * ----------------------------------------------------------------------
 */

static inline bool
AddSimpleChainToCallContext(
    Object *const oPtr,		/* Object to add call chain entries for. */
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. [TIP 500] */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    bool foundPrivate = false, blockedUnexported = false;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);

	if (hPtr != NULL) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (!IS_PRIVATE(mPtr)) {
		if (WANT_PUBLIC(flags)) {
		    if (!IS_PUBLIC(mPtr)) {
			blockedUnexported = true;
		    } else {
			flags |= DEFINITE_PUBLIC;
		    }
		} else {
		    flags |= DEFINITE_PROTECTED;
		}
	    }
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
 *	- Still across the same object structure (same local epoch), and
 *	- No public/private/filter magic leakage (same flags, modulo the fact
 *	  that a public chain will satisfy a non-public call).
 *
 * ----------------------------------------------------------------------
 */

static inline int
IsStillValid(
    CallChain *callPtr,
    Object *oPtr,
    int flags,
    int mask)
{
    if ((oPtr->flags & USE_CLASS_CACHE)) {
	/*
	 * If the object is in a weird state (due to stereotype tricks) then
	 * just declare the cache invalid. [Bug 7842f33a5c]
	 */
	if (!oPtr->selfCls) {
	    return 0;
	}
	oPtr = oPtr->selfCls->thisPtr;
	flags |= USE_CLASS_CACHE;
    }
    return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
	    && (callPtr->epoch == oPtr->fPtr->epoch)
	    && (callPtr->objectEpoch == oPtr->epoch)







|












|







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
 *	- Still across the same object structure (same local epoch), and
 *	- No public/private/filter magic leakage (same flags, modulo the fact
 *	  that a public chain will satisfy a non-public call).
 *
 * ----------------------------------------------------------------------
 */

static inline bool
IsStillValid(
    CallChain *callPtr,
    Object *oPtr,
    int flags,
    int mask)
{
    if ((oPtr->flags & USE_CLASS_CACHE)) {
	/*
	 * If the object is in a weird state (due to stereotype tricks) then
	 * just declare the cache invalid. [Bug 7842f33a5c]
	 */
	if (!oPtr->selfCls) {
	    return false;
	}
	oPtr = oPtr->selfCls->thisPtr;
	flags |= USE_CLASS_CACHE;
    }
    return ((callPtr->objectCreationEpoch == oPtr->creationEpoch)
	    && (callPtr->epoch == oPtr->fPtr->epoch)
	    && (callPtr->objectEpoch == oPtr->epoch)
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
				 * to be in the same object as the
				 * methodNameObj. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    ChainBuilder cb;
    Tcl_Size count;
    int doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }
    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
	hPtr = NULL;
	doFilters = 0;

	/*
	 * Check if we have a cached valid constructor or destructor.
	 */

	if (flags & CONSTRUCTOR) {
	    callPtr = oPtr->selfCls->constructorChainPtr;







|








|







1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
				 * to be in the same object as the
				 * methodNameObj. */
{
    CallContext *contextPtr;
    CallChain *callPtr;
    ChainBuilder cb;
    Tcl_Size count;
    bool doFilters, donePrivate = false;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (cacheInThisObj == NULL) {
	cacheInThisObj = methodNameObj;
    }
    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
	hPtr = NULL;
	doFilters = false;

	/*
	 * Check if we have a cached valid constructor or destructor.
	 */

	if (flags & CONSTRUCTOR) {
	    callPtr = oPtr->selfCls->constructorChainPtr;
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
		callPtr->refCount++;
		goto returnContext;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
	    TclOODeleteChain(callPtr);
	}

	doFilters = 1;
    }

    callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
    InitCallChain(callPtr, oPtr, flags);

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;







|







1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
		callPtr->refCount++;
		goto returnContext;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
	    TclOODeleteChain(callPtr);
	}

	doFilters = true;
    }

    callPtr = (CallChain *) Tcl_Alloc(sizeof(CallChain));
    InitCallChain(callPtr, oPtr, flags);

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
     * in the middle of processing a filter).
     */

    if (doFilters) {
	Tcl_Obj *filterObj;
	Class *mixinPtr;

	doFilters = 1;
	Tcl_InitObjHashTable(&doneFilters);
	FOREACH(mixinPtr, oPtr->mixins) {
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN);
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    OBJECT_MIXIN);
	}







|







1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
     * in the middle of processing a filter).
     */

    if (doFilters) {
	Tcl_Obj *filterObj;
	Class *mixinPtr;

	doFilters = true;
	Tcl_InitObjHashTable(&doneFilters);
	FOREACH(mixinPtr, oPtr->mixins) {
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN);
	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
		    OBJECT_MIXIN);
	}
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
 *	Helper for AddSimpleChainToCallContext that is used to find private
 *	methds and add them to the call chain. Returns true when a private
 *	method is found and added. [TIP 500]
 *
 * ----------------------------------------------------------------------
 */

static int
AddPrivatesFromClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */







|







1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
 *	Helper for AddSimpleChainToCallContext that is used to find private
 *	methds and add them to the call chain. Returns true when a private
 *	method is found and added. [TIP 500]
 *
 * ----------------------------------------------------------------------
 */

static bool
AddPrivatesFromClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Class *const contextCls,	/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. */
    Tcl_Obj *const methodName,	/* Name of method to add the call chain
				 * entries for. */
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
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
     * Note also that it's possible to end up with a null classPtr here if
     * there is a call into stereotypical object after it has finished running
     * its destructor phase. [Bug 7842f33a5c]
     */

  tailRecurse:
    if (classPtr == NULL) {
	return 0;
    }
    FOREACH(superPtr, classPtr->mixins) {
	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
		filterDecl)) {
	    return 1;
	}
    }

    if (classPtr == contextCls) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodName);

	if (hPtr != NULL) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
		return 1;
	    }
	}
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		    methodName, cbPtr, doneFilters, flags, filterDecl)) {
		return 1;
	    }
	}
	TCL_FALLTHROUGH();
    case 0:
	return 0;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassChainToCallContext --
 *
 *	Construct a call-chain from a class hierarchy.
 *
 * ----------------------------------------------------------------------
 */

static int
AddSimpleClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    int privateDanger = 0;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.







|





|













|












|




|













|














|







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
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
     * Note also that it's possible to end up with a null classPtr here if
     * there is a call into stereotypical object after it has finished running
     * its destructor phase. [Bug 7842f33a5c]
     */

  tailRecurse:
    if (classPtr == NULL) {
	return false;
    }
    FOREACH(superPtr, classPtr->mixins) {
	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
		filterDecl)) {
	    return true;
	}
    }

    if (classPtr == contextCls) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodName);

	if (hPtr != NULL) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
		return true;
	    }
	}
    }

    switch (classPtr->superclasses.num) {
    case 1:
	classPtr = classPtr->superclasses.list[0];
	goto tailRecurse;
    default:
	FOREACH(superPtr, classPtr->superclasses) {
	    if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		    methodName, cbPtr, doneFilters, flags, filterDecl)) {
		return true;
	    }
	}
	TCL_FALLTHROUGH();
    case 0:
	return false;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * AddSimpleClassChainToCallContext --
 *
 *	Construct a call-chain from a class hierarchy.
 *
 * ----------------------------------------------------------------------
 */

static bool
AddSimpleClassChainToCallContext(
    Class *classPtr,		/* Class to add the call chain entries for. */
    Tcl_Obj *const methodNameObj,
				/* Name of method to add the call chain
				 * entries for. */
    ChainBuilder *const cbPtr,	/* Where to add the call chain entries. */
    Tcl_HashTable *const doneFilters,
				/* Where to record what call chain entries
				 * have been processed. */
    int flags,			/* What sort of call chain are we building. */
    Class *const filterDecl)	/* The class that declared the filter. If
				 * NULL, either the filter was declared by the
				 * object or this isn't a filter. */
{
    bool privateDanger = false;
    Class *superPtr;

    /*
     * We hard-code the tail-recursive form. It's by far the most common case
     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
	AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
		filterDecl, flags);
    } else {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodNameObj);

	if (classPtr->flags & HAS_PRIVATE_METHODS) {
	    privateDanger |= 1;
	}
	if (hPtr != NULL) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (!IS_PRIVATE(mPtr)) {
		if (!(flags & KNOWN_STATE)) {
		    if (flags & PUBLIC_METHOD) {







|







1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
	AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
		filterDecl, flags);
    } else {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodNameObj);

	if (classPtr->flags & HAS_PRIVATE_METHODS) {
	    privateDanger |= true;
	}
	if (hPtr != NULL) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (!IS_PRIVATE(mPtr)) {
		if (!(flags & KNOWN_STATE)) {
		    if (flags & PUBLIC_METHOD) {
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */

Tcl_Namespace *
TclOOGetDefineContextNamespace(
    Tcl_Interp *interp,		/* In what interpreter should namespace names
				 * actually be resolved. */
    Object *oPtr,		/* The object to get the context for. */
    int forClass)		/* What sort of context are we looking for.
				 * If true, we are going to use this for
				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;







|







1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */

Tcl_Namespace *
TclOOGetDefineContextNamespace(
    Tcl_Interp *interp,		/* In what interpreter should namespace names
				 * actually be resolved. */
    Object *oPtr,		/* The object to get the context for. */
    bool forClass)		/* What sort of context are we looking for.
				 * If true, we are going to use this for
				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;
Changes to generic/tclOODefineCmds.c.
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
 * IsPrivateDefine --
 *
 *	Extracts whether the current context is handling private definitions.
 *
 * ----------------------------------------------------------------------
 */

static inline int
IsPrivateDefine(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;

    if (!iPtr->varFramePtr) {
	return 0;
    }
    return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
}

/*
 * ----------------------------------------------------------------------
 *







|






|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
 * IsPrivateDefine --
 *
 *	Extracts whether the current context is handling private definitions.
 *
 * ----------------------------------------------------------------------
 */

static inline bool
IsPrivateDefine(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;

    if (!iPtr->varFramePtr) {
	return false;
    }
    return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
}

/*
 * ----------------------------------------------------------------------
 *
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
    }

    /*
     * Make the oo::define namespace the current namespace and evaluate the
     * command(s).
     */

    nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    int result;
    if (objc == 3) {







|







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
    }

    /*
     * Make the oo::define namespace the current namespace and evaluate the
     * command(s).
     */

    nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, true);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    int result;
    if (objc == 3) {
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
    }

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    Tcl_Namespace *nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    int result;
    if (objc == 3) {







|







1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
    }

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    Tcl_Namespace *nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, false);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }

    AddRef(oPtr);
    int result;
    if (objc == 3) {
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
    }

    if (objc < 2) {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
	return TCL_OK;
    }

    int isPrivate = IsPrivateDefine(interp);

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    Tcl_Namespace *nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (isPrivate) {
	((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
    }








|






|







1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
    }

    if (objc < 2) {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
	return TCL_OK;
    }

    bool isPrivate = IsPrivateDefine(interp);

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    Tcl_Namespace *nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, false);
    if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (isPrivate) {
	((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
    }

1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */

    int wasClass = (oPtr->classPtr != NULL);
    int willBeClass = TclOOIsReachable(fPtr->classCls, clsPtr);

    if (oPtr->selfCls != clsPtr) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);
	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);







|
|







1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */

    bool wasClass = (oPtr->classPtr != NULL);
    bool willBeClass = TclOOIsReachable(fPtr->classCls, clsPtr);

    if (oPtr->selfCls != clsPtr) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
	TclOODecrRefCount(oPtr->selfCls->thisPtr);
	oPtr->selfCls = clsPtr;
	AddRef(oPtr->selfCls->thisPtr);
	TclOOAddToInstances(oPtr, oPtr->selfCls);
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
TclOODefineExportObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceExport = (clientData != NULL);
    int changed = 0;

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

    Object *oPtr = GetCheckedContextObject(interp, isInstanceExport);







|







1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
TclOODefineExportObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceExport = (clientData != NULL);
    bool changed = false;

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

    Object *oPtr = GetCheckedContextObject(interp, isInstanceExport);
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	}
	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
	    mPtr->flags |= PUBLIC_METHOD;
	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
	    changed = 1;
	}
    }

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








|







1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	}
	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
	    mPtr->flags |= PUBLIC_METHOD;
	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
	    changed = true;
	}
    }

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

2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
TclOODefineUnexportObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceUnexport = (clientData != NULL);
    int changed = 0;

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

    Object *oPtr = GetCheckedContextObject(interp, isInstanceUnexport);







|







2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
TclOODefineUnexportObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    int isInstanceUnexport = (clientData != NULL);
    bool changed = false;

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

    Object *oPtr = GetCheckedContextObject(interp, isInstanceUnexport);
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
	    Tcl_IncrRefCount(objv[i]);
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	}
	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
	    changed = 1;
	}
    }

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








|







2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
	    Tcl_IncrRefCount(objv[i]);
	    Tcl_SetHashValue(hPtr, mPtr);
	} else {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	}
	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
	    changed = true;
	}
    }

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

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
 *
 *	Helper for the helpers. Scans a property list and does the filtering
 *	or adding of the property to add or remove
 *
 * ----------------------------------------------------------------------
 */

static int
BuildPropertyList(
    PropertyList *propsList,	/* Property list to scan. */
    Tcl_Obj *propName,		/* Property to add/remove. */
    int addingProp,		/* True if we're adding, false if removing. */
    Tcl_Obj *listObj)		/* The list of property names we're building */
{
    int present = 0, changed = 0;
    Tcl_Obj *other;

    Tcl_SetListObj(listObj, 0, NULL);
    FOREACH(other, *propsList) {
	if (!TclStringCmp(propName, other, 1, 0, TCL_INDEX_NONE)) {
	    present = 1;
	    if (!addingProp) {
		changed = 1;
		continue;
	    }
	}
	Tcl_ListObjAppendElement(NULL, listObj, other);
    }
    if (!present && addingProp) {
	Tcl_ListObjAppendElement(NULL, listObj, propName);
	changed = 1;
    }
    return changed;
}

void
TclOORegisterInstanceProperty(
    Object *oPtr,		/* Object that owns the property slots. */
    Tcl_Obj *propName,		/* Property to add/remove. Must include the
				 * hyphen if one is desired; this is the value
				 * that is actually placed in the slot. */
    int registerReader,		/* True if we're adding the property name to
				 * the readable property slot. False if we're
				 * removing the property name from the slot. */
    int registerWriter)		/* True if we're adding the property name to
				 * the writable property slot. False if we're
				 * removing the property name from the slot. */
{
    Tcl_Obj *listObj = Tcl_NewObj();	/* Working buffer. */
    Tcl_Obj **objv;
    Tcl_Size count;








|



|


|





|

|







|










|


|







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
 *
 *	Helper for the helpers. Scans a property list and does the filtering
 *	or adding of the property to add or remove
 *
 * ----------------------------------------------------------------------
 */

static bool
BuildPropertyList(
    PropertyList *propsList,	/* Property list to scan. */
    Tcl_Obj *propName,		/* Property to add/remove. */
    bool addingProp,		/* True if we're adding, false if removing. */
    Tcl_Obj *listObj)		/* The list of property names we're building */
{
    bool present = false, changed = false;
    Tcl_Obj *other;

    Tcl_SetListObj(listObj, 0, NULL);
    FOREACH(other, *propsList) {
	if (!TclStringCmp(propName, other, 1, 0, TCL_INDEX_NONE)) {
	    present = true;
	    if (!addingProp) {
		changed = true;
		continue;
	    }
	}
	Tcl_ListObjAppendElement(NULL, listObj, other);
    }
    if (!present && addingProp) {
	Tcl_ListObjAppendElement(NULL, listObj, propName);
	changed = true;
    }
    return changed;
}

void
TclOORegisterInstanceProperty(
    Object *oPtr,		/* Object that owns the property slots. */
    Tcl_Obj *propName,		/* Property to add/remove. Must include the
				 * hyphen if one is desired; this is the value
				 * that is actually placed in the slot. */
    bool registerReader,	/* True if we're adding the property name to
				 * the readable property slot. False if we're
				 * removing the property name from the slot. */
    bool registerWriter)	/* True if we're adding the property name to
				 * the writable property slot. False if we're
				 * removing the property name from the slot. */
{
    Tcl_Obj *listObj = Tcl_NewObj();	/* Working buffer. */
    Tcl_Obj **objv;
    Tcl_Size count;

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

void
TclOORegisterProperty(
    Class *clsPtr,		/* Class that owns the property slots. */
    Tcl_Obj *propName,		/* Property to add/remove. Must include the
				 * hyphen if one is desired; this is the value
				 * that is actually placed in the slot. */
    int registerReader,		/* True if we're adding the property name to
				 * the readable property slot. False if we're
				 * removing the property name from the slot. */
    int registerWriter)		/* True if we're adding the property name to
				 * the writable property slot. False if we're
				 * removing the property name from the slot. */
{
    Tcl_Obj *listObj = Tcl_NewObj();	/* Working buffer. */
    Tcl_Obj **objv;
    Tcl_Size count;
    int changed = 0;

    if (BuildPropertyList(&clsPtr->properties.readable, propName,
	    registerReader, listObj)) {
	TclListObjGetElements(NULL, listObj, &count, &objv);
	TclOOInstallReadableProperties(&clsPtr->properties, count, objv);
	changed = 1;
    }

    if (BuildPropertyList(&clsPtr->properties.writable, propName,
	    registerWriter, listObj)) {
	TclListObjGetElements(NULL, listObj, &count, &objv);
	TclOOInstallWritableProperties(&clsPtr->properties, count, objv);
	changed = 1;
    }
    Tcl_BounceRefCount(listObj);
    if (changed) {
	BumpGlobalEpoch(clsPtr->thisPtr->fPtr->interp, clsPtr);
    }
}








|


|






|





|






|







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

void
TclOORegisterProperty(
    Class *clsPtr,		/* Class that owns the property slots. */
    Tcl_Obj *propName,		/* Property to add/remove. Must include the
				 * hyphen if one is desired; this is the value
				 * that is actually placed in the slot. */
    bool registerReader,	/* True if we're adding the property name to
				 * the readable property slot. False if we're
				 * removing the property name from the slot. */
    bool registerWriter)	/* True if we're adding the property name to
				 * the writable property slot. False if we're
				 * removing the property name from the slot. */
{
    Tcl_Obj *listObj = Tcl_NewObj();	/* Working buffer. */
    Tcl_Obj **objv;
    Tcl_Size count;
    bool changed = false;

    if (BuildPropertyList(&clsPtr->properties.readable, propName,
	    registerReader, listObj)) {
	TclListObjGetElements(NULL, listObj, &count, &objv);
	TclOOInstallReadableProperties(&clsPtr->properties, count, objv);
	changed = true;
    }

    if (BuildPropertyList(&clsPtr->properties.writable, propName,
	    registerWriter, listObj)) {
	TclListObjGetElements(NULL, listObj, &count, &objv);
	TclOOInstallWritableProperties(&clsPtr->properties, count, objv);
	changed = true;
    }
    Tcl_BounceRefCount(listObj);
    if (changed) {
	BumpGlobalEpoch(clsPtr->thisPtr->fPtr->interp, clsPtr);
    }
}

Changes to generic/tclOOInfo.c.
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
    static const char *const categories[] = {
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };
    enum IsACats {
	IsClass, IsMetaclass, IsMixin, IsObject, IsType
    } idx;
    Object *oPtr, *o2Ptr;
    int result = 0;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
	    &idx) != TCL_OK) {







|







471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
    static const char *const categories[] = {
	"class", "metaclass", "mixin", "object", "typeof", NULL
    };
    enum IsACats {
	IsClass, IsMetaclass, IsMixin, IsObject, IsType
    } idx;
    Object *oPtr, *o2Ptr;
    bool result = false;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0,
	    &idx) != TCL_OK) {
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
    if (oPtr == NULL) {
	goto failPrecondition;
    }

    switch (idx) {
    case IsObject:
	result = 1;
	break;
    case IsClass:
	result = (oPtr->classPtr != NULL);
	break;
    case IsMetaclass:
	if (oPtr->classPtr != NULL) {
	    result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,







|







519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
    if (oPtr == NULL) {
	goto failPrecondition;
    }

    switch (idx) {
    case IsObject:
	result = true;
	break;
    case IsClass:
	result = (oPtr->classPtr != NULL);
	break;
    case IsMetaclass:
	if (oPtr->classPtr != NULL) {
	    result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (!mixinPtr) {
		    continue;
		}
		if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
		    result = 1;
		    break;
		}
	    }
	}
	break;
    case IsType:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);







|







543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (!mixinPtr) {
		    continue;
		}
		if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
		    result = true;
		    break;
		}
	    }
	}
	break;
    case IsType:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_LOCALPRIVATE,
	SCOPE_DEFAULT = -1
    };
    int flag = PUBLIC_METHOD, recurse = 0, scope = SCOPE_DEFAULT;

    Tcl_Obj *namePtr, *resultObj;

    /*
     * Parse arguments.
     */

    if (objc < 2) {







|
>







601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_LOCALPRIVATE,
	SCOPE_DEFAULT = -1
    };
    int flag = PUBLIC_METHOD, scope = SCOPE_DEFAULT;
    bool recurse = false;
    Tcl_Obj *namePtr, *resultObj;

    /*
     * Parse arguments.
     */

    if (objc < 2) {
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
	for (int i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &idx) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case OPT_ALL:
		recurse = 1;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;







|







625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
	for (int i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &idx) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case OPT_ALL:
		recurse = true;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
		break;
	    default:
		TCL_UNREACHABLE();
	    }
	}
    }
    if (scope != SCOPE_DEFAULT) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;







|







650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
		break;
	    default:
		TCL_UNREACHABLE();
	    }
	}
    }
    if (scope != SCOPE_DEFAULT) {
	recurse = false;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *resultObj;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", TclGetString(objv[2])) != 0) {
	    TclPrintfResult(interp, "option \"%s\" is not exactly \"-private\"",
		    TclGetString(objv[2]));
	    OO_ERROR(interp, BAD_ARG);
	    return TCL_ERROR;
	}
	isPrivate = 1;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);







|












|







867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    Tcl_Obj *resultObj;
    bool isPrivate = false;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", TclGetString(objv[2])) != 0) {
	    TclPrintfResult(interp, "option \"%s\" is not exactly \"-private\"",
		    TclGetString(objv[2]));
	    OO_ERROR(interp, BAD_ARG);
	    return TCL_ERROR;
	}
	isPrivate = true;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
1306
1307
1308
1309
1310
1311
1312
1313

1314
1315
1316
1317
1318
1319
1320
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_DEFAULT = -1
    };
    int flag = PUBLIC_METHOD, recurse = 0, scope = SCOPE_DEFAULT;

    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;
    Class *clsPtr;

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







|
>







1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_DEFAULT = -1
    };
    int flag = PUBLIC_METHOD, scope = SCOPE_DEFAULT;
    bool recurse = false;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;
    Class *clsPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
	return TCL_ERROR;
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
	for (i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &idx) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case OPT_ALL:
		recurse = 1;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;







|







1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
	for (i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
		    &idx) != TCL_OK) {
		return TCL_ERROR;
	    }
	    switch (idx) {
	    case OPT_ALL:
		recurse = true;
		break;
	    case OPT_LOCALPRIVATE:
		flag = PRIVATE_METHOD;
		break;
	    case OPT_PRIVATE:
		flag = 0;
		break;
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
		break;
	    default:
		TCL_UNREACHABLE();
	    }
	}
    }
    if (scope != SCOPE_DEFAULT) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;







|







1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
		break;
	    default:
		TCL_UNREACHABLE();
	    }
	}
    }
    if (scope != SCOPE_DEFAULT) {
	recurse = false;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;
	    break;
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
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *resultObj;
    int isPrivate = 0;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", TclGetString(objv[2])) != 0) {
	    TclPrintfResult(interp, "option \"%s\" is not exactly \"-private\"",
		    TclGetString(objv[2]));
	    OO_ERROR(interp, BAD_ARG);
	    return TCL_ERROR;
	}
	isPrivate = 1;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);







|












|







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
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    Tcl_Obj *resultObj;
    bool isPrivate = false;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
	return TCL_ERROR;
    }
    if (objc == 3) {
	if (strcmp("-private", TclGetString(objv[2])) != 0) {
	    TclPrintfResult(interp, "option \"%s\" is not exactly \"-private\"",
		    TclGetString(objv[2]));
	    OO_ERROR(interp, BAD_ARG);
	    return TCL_ERROR;
	}
	isPrivate = true;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
Changes to generic/tclOOInt.h.
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
				 * exposed by this object or class (in its
				 * stereotypical instancs). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Obj *allWritableCache;	/* The cache of all writable properties
				 * exposed by this object or class (in its
				 * stereotypical instances). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Size epoch;			/* The epoch that the caches are valid for. */
};

/*
 * Now, the definition of what an object actually is.
 */

struct Object {







|







198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
				 * exposed by this object or class (in its
				 * stereotypical instancs). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Obj *allWritableCache;	/* The cache of all writable properties
				 * exposed by this object or class (in its
				 * stereotypical instances). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Size epoch;		/* The epoch that the caches are valid for. */
};

/*
 * Now, the definition of what an object actually is.
 */

struct Object {
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
/*
 * Information relating to the invocation of a particular method implementation
 * in a call chain.
 */
struct MInvoke {
    Method *mPtr;		/* Reference to the method implementation
				 * record. */
    int isFilter;		/* Whether this is a filter invocation. */
    Class *filterDeclarer;	/* What class decided to add the filter; if
				 * NULL, it was added by the object. */
};

/*
 * The cacheable part of a call context.
 */







|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
/*
 * Information relating to the invocation of a particular method implementation
 * in a call chain.
 */
struct MInvoke {
    Method *mPtr;		/* Reference to the method implementation
				 * record. */
    bool isFilter;		/* Whether this is a filter invocation. */
    Class *filterDeclarer;	/* What class decided to add the filter; if
				 * NULL, it was added by the object. */
};

/*
 * The cacheable part of a call context.
 */
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)

/*
 * Structure containing definition information about basic class methods.
 */
struct DeclaredClassMethod {
    const char *name;		/* Name of the method in question. */
    int isPublic;		/* Whether the method is public by default. */
    Tcl_MethodType definition;	/* How to call the method. */
};

/*
 *----------------------------------------------------------------
 * Commands relating to OO support.
 *----------------------------------------------------------------







|







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)

/*
 * Structure containing definition information about basic class methods.
 */
struct DeclaredClassMethod {
    const char *name;		/* Name of the method in question. */
    bool isPublic;		/* Whether the method is public by default. */
    Tcl_MethodType definition;	/* How to call the method. */
};

/*
 *----------------------------------------------------------------
 * Commands relating to OO support.
 *----------------------------------------------------------------
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
			    const char *nsNameStr, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE Object *	TclNewObjectInstanceCommon(Tcl_Interp *interp,
			    Class *classPtr,
			    const char *nameStr,
			    const char *nsNameStr);
MODULE_SCOPE int	TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int	TclOOObjectDestroyed(Object *oPtr);
MODULE_SCOPE const char *TclOOContextTypeName(CallContext *contextPtr);
MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODeleteDescendants(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Object *contextObjPtr, Class *contextClsPtr,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Class *	TclOOGetClassDefineCmdContext(Tcl_Interp *interp);
MODULE_SCOPE Class *	TclOOGetClassFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
			    Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
			    Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE size_t	TclOOGetSortedClassMethodList(Class *clsPtr,







|

















|







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
			    const char *nsNameStr, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE Object *	TclNewObjectInstanceCommon(Tcl_Interp *interp,
			    Class *classPtr,
			    const char *nameStr,
			    const char *nsNameStr);
MODULE_SCOPE bool	TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int	TclOOObjectDestroyed(Object *oPtr);
MODULE_SCOPE const char *TclOOContextTypeName(CallContext *contextPtr);
MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODeleteDescendants(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Object *contextObjPtr, Class *contextClsPtr,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Class *	TclOOGetClassDefineCmdContext(Tcl_Interp *interp);
MODULE_SCOPE Class *	TclOOGetClassFromObj(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
			    Tcl_Interp *interp, Object *oPtr, bool forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
			    Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE size_t	TclOOGetSortedClassMethodList(Class *clsPtr,
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
MODULE_SCOPE int	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
			    CallChain *callPtr);
MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
			    CallContext *contextPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
			    int writable);
MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetPropertyList(PropertyList *propList);
MODULE_SCOPE void	TclOOReleasePropertyStorage(PropertyStorage *propsPtr);
MODULE_SCOPE void	TclOOInstallReadableProperties(PropertyStorage *props,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void	TclOOInstallWritableProperties(PropertyStorage *props,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclOOInstallStdPropertyImpls(void *useInstance,
			    Tcl_Interp *interp, Tcl_Obj *propName,
			    int readable, int writable);
MODULE_SCOPE void	TclOORegisterProperty(Class *clsPtr,
			    Tcl_Obj *propName, int mayRead, int mayWrite);
MODULE_SCOPE void	TclOORegisterInstanceProperty(Object *oPtr,
			    Tcl_Obj *propName, int mayRead, int mayWrite);

/*
 * Include all the private API, generated from tclOO.decls.
 */

#include "tclOOIntDecls.h"








|









|

|

|







618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
MODULE_SCOPE int	TclOORemoveFromSubclasses(Class *subPtr,
			    Class *superPtr);
MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
			    CallChain *callPtr);
MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
			    CallContext *contextPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
			    bool writable);
MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE Tcl_Obj *	TclOOGetPropertyList(PropertyList *propList);
MODULE_SCOPE void	TclOOReleasePropertyStorage(PropertyStorage *propsPtr);
MODULE_SCOPE void	TclOOInstallReadableProperties(PropertyStorage *props,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void	TclOOInstallWritableProperties(PropertyStorage *props,
			    Tcl_Size objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclOOInstallStdPropertyImpls(void *useInstance,
			    Tcl_Interp *interp, Tcl_Obj *propName,
			    bool readable, bool writable);
MODULE_SCOPE void	TclOORegisterProperty(Class *clsPtr,
			    Tcl_Obj *propName, bool mayRead, bool mayWrite);
MODULE_SCOPE void	TclOORegisterInstanceProperty(Object *oPtr,
			    Tcl_Obj *propName, bool mayRead, bool mayWrite);

/*
 * Include all the private API, generated from tclOO.decls.
 */

#include "tclOOIntDecls.h"

Changes to generic/tclOOMethod.c.
1074
1075
1076
1077
1078
1079
1080
1081

1082
1083
1084
1085
1086
1087
1088
    OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVar;
    Tcl_HashEntry *hPtr;
    int isNew, cacheIt;

    Tcl_Size varLen, len;
    const char *match, *varName;

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
     * in a procedure of that namespace) then we do nothing.







|
>







1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
    OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *variableObj;
    PrivateVariableMapping *privateVar;
    Tcl_HashEntry *hPtr;
    int isNew;
    bool cacheIt;
    Tcl_Size varLen, len;
    const char *match, *varName;

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
     * in a procedure of that namespace) then we do nothing.
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
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
    if (contextPtr->callPtr->chain[contextPtr->index]
	    .mPtr->declaringClassPtr != NULL) {
	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->privateVariables) {
	    match = Tcl_GetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = 0;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->variables) {
	    match = Tcl_GetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = 0;
		goto gotMatch;
	    }
	}
    } else {
	FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
	    match = Tcl_GetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = 1;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->oPtr->variables) {
	    match = Tcl_GetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = 1;
		goto gotMatch;
	    }
	}
    }
    return NULL;

    /*







|







|








|






|







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
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
    if (contextPtr->callPtr->chain[contextPtr->index]
	    .mPtr->declaringClassPtr != NULL) {
	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->privateVariables) {
	    match = Tcl_GetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = false;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->variables) {
	    match = Tcl_GetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = false;
		goto gotMatch;
	    }
	}
    } else {
	FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
	    match = Tcl_GetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = true;
		goto gotMatch;
	    }
	}
	FOREACH(variableObj, contextPtr->oPtr->variables) {
	    match = Tcl_GetStringFromObj(variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		cacheIt = true;
		goto gotMatch;
	    }
	}
    }
    return NULL;

    /*
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
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
{
    Method *mPtr = (Method *) method;

    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

int
Tcl_MethodIsType(
    Tcl_Method method,
    const Tcl_MethodType *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1");
    }
    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

int
Tcl_MethodIsType2(
    Tcl_Method method,
    const Tcl_MethodType2 *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2");
    }
    if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

int
Tcl_MethodIsPublic(
    Tcl_Method method)
{
    return (((Method *) method)->flags & PUBLIC_METHOD) ? 1 : 0;
}

int
Tcl_MethodIsPrivate(
    Tcl_Method method)
{
    return (((Method *) method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
}

/*
 * Extended method construction for itcl-ng.
 */

Tcl_Method







|

|


















|

|


















|

|






|






|







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
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
{
    Method *mPtr = (Method *) method;

    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return true;
    }
    return false;
}

int
Tcl_MethodIsType(
    Tcl_Method method,
    const Tcl_MethodType *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1");
    }
    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return true;
    }
    return false;
}

int
Tcl_MethodIsType2(
    Tcl_Method method,
    const Tcl_MethodType2 *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2");
    }
    if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) {
	if (clientDataPtr != NULL) {
	    *clientDataPtr = mPtr->clientData;
	}
	return true;
    }
    return false;
}

int
Tcl_MethodIsPublic(
    Tcl_Method method)
{
    return (((Method *) method)->flags & PUBLIC_METHOD) ? true : false;
}

int
Tcl_MethodIsPrivate(
    Tcl_Method method)
{
    return (((Method *) method)->flags & TRUE_PRIVATE_METHOD) ? true : false;
}

/*
 * Extended method construction for itcl-ng.
 */

Tcl_Method
Changes to generic/tclOOProp.c.
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
static int		Configurable_Setter(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static void		DetailsDeleter(void *clientData);
static int		DetailsCloner(Tcl_Interp *, void *oldClientData,
			    void **newClientData);
static void		ImplementObjectProperty(Tcl_Object targetObject,
			    Tcl_Obj *propNamePtr, int installGetter,
			    int installSetter);
static void		ImplementClassProperty(Tcl_Class targetObject,
			    Tcl_Obj *propNamePtr, int installGetter,
			    int installSetter);

/*
 * Method descriptors
 */

static const Tcl_MethodType GetterType = {
    TCL_OO_METHOD_VERSION_1,







|
|

|
|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
static int		Configurable_Setter(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static void		DetailsDeleter(void *clientData);
static int		DetailsCloner(Tcl_Interp *, void *oldClientData,
			    void **newClientData);
static void		ImplementObjectProperty(Tcl_Object targetObject,
			    Tcl_Obj *propNamePtr, bool installGetter,
			    bool installSetter);
static void		ImplementClassProperty(Tcl_Class targetObject,
			    Tcl_Obj *propNamePtr, bool installGetter,
			    bool installSetter);

/*
 * Method descriptors
 */

static const Tcl_MethodType GetterType = {
    TCL_OO_METHOD_VERSION_1,
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
 * ----------------------------------------------------------------------
 */

void
ImplementObjectProperty(
    Tcl_Object targetObject,	/* What to install into. */
    Tcl_Obj *propNamePtr,	/* Property name. */
    int installGetter,		/* Whether to install a standard getter. */
    int installSetter)		/* Whether to install a standard setter. */
{
    const char *propName = TclGetString(propNamePtr);

    while (propName[0] == '-') {
	propName++;
    }
    if (installGetter) {







|
|







468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
 * ----------------------------------------------------------------------
 */

void
ImplementObjectProperty(
    Tcl_Object targetObject,	/* What to install into. */
    Tcl_Obj *propNamePtr,	/* Property name. */
    bool installGetter,		/* Whether to install a standard getter. */
    bool installSetter)		/* Whether to install a standard setter. */
{
    const char *propName = TclGetString(propNamePtr);

    while (propName[0] == '-') {
	propName++;
    }
    if (installGetter) {
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
    }
}

void
ImplementClassProperty(
    Tcl_Class targetClass,	/* What to install into. */
    Tcl_Obj *propNamePtr,	/* Property name. */
    int installGetter,		/* Whether to install a standard getter. */
    int installSetter)		/* Whether to install a standard setter. */
{
    const char *propName = TclGetString(propNamePtr);

    while (propName[0] == '-') {
	propName++;
    }
    if (installGetter) {







|
|







496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
    }
}

void
ImplementClassProperty(
    Tcl_Class targetClass,	/* What to install into. */
    Tcl_Obj *propNamePtr,	/* Property name. */
    bool installGetter,		/* Whether to install a standard getter. */
    bool installSetter)		/* Whether to install a standard setter. */
{
    const char *propName = TclGetString(propNamePtr);

    while (propName[0] == '-') {
	propName++;
    }
    if (installGetter) {
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
 *
 * ----------------------------------------------------------------------
 */

static void
FindClassProps(
    Class *clsPtr,		/* The object to inspect. Must exist. */
    int writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    Tcl_Obj *propName;
    Class *mixin, *sup;

  tailRecurse:







|







533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
 *
 * ----------------------------------------------------------------------
 */

static void
FindClassProps(
    Class *clsPtr,		/* The object to inspect. Must exist. */
    bool writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    Tcl_Obj *propName;
    Class *mixin, *sup;

  tailRecurse:
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
 *
 * ----------------------------------------------------------------------
 */

static void
FindObjectProps(
    Object *oPtr,		/* The object to inspect. Must exist. */
    int writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    Tcl_Obj *propName;
    Class *mixin;

    if (writable) {







|







583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
 *
 * ----------------------------------------------------------------------
 */

static void
FindObjectProps(
    Object *oPtr,		/* The object to inspect. Must exist. */
    bool writable,		/* Whether we're after the readable or writable
				 * property set. */
    Tcl_HashTable *accumulator)	/* Where to gather the names. */
{
    Tcl_Obj *propName;
    Class *mixin;

    if (writable) {
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
 *
 * ----------------------------------------------------------------------
 */

static Tcl_Obj *
GetAllClassProperties(
    Class *clsPtr,		/* The class to inspect. Must exist. */
    int writable,		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
    int *allocated)		/* Address of variable to set to true if a
				 * Tcl_Obj was allocated and may be safely
				 * modified by the caller. */
{
    Tcl_HashTable hashTable;
    Tcl_Obj *propName, *result;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = 0;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {
		*allocated = 0;
		return clsPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindClassProps(clsPtr, writable, &hashTable);
    TclNewObj(result);
    FOREACH_HASH_KEY(propName, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);







|


|













|




|









|







620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
 *
 * ----------------------------------------------------------------------
 */

static Tcl_Obj *
GetAllClassProperties(
    Class *clsPtr,		/* The class to inspect. Must exist. */
    bool writable,		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
    bool *allocated)		/* Address of variable to set to true if a
				 * Tcl_Obj was allocated and may be safely
				 * modified by the caller. */
{
    Tcl_HashTable hashTable;
    Tcl_Obj *propName, *result;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = false;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {
		*allocated = false;
		return clsPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = true;
    Tcl_InitObjHashTable(&hashTable);
    FindClassProps(clsPtr, writable, &hashTable);
    TclNewObj(result);
    FOREACH_HASH_KEY(propName, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,		/* The object to inspect. Must exist. */
    int writable)		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
{
    Tcl_HashTable hashTable;
    Tcl_Obj *propName, *result;

    /*







|







736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,		/* The object to inspect. Must exist. */
    bool writable)		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
{
    Tcl_HashTable hashTable;
    Tcl_Obj *propName, *result;

    /*
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
 * ----------------------------------------------------------------------
 */
int
TclOOInstallStdPropertyImpls(
    void *useInstance,
    Tcl_Interp *interp,
    Tcl_Obj *propName,
    int readable,
    int writable)
{
    const char *name, *reason;
    Tcl_Size len;
    char flag = TCL_DONT_QUOTE_HASH;

    /*
     * Validate the property name. Note that just calling TclScanElement() is







|
|







944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
 * ----------------------------------------------------------------------
 */
int
TclOOInstallStdPropertyImpls(
    void *useInstance,
    Tcl_Interp *interp,
    Tcl_Obj *propName,
    bool readable,
    bool writable)
{
    const char *name, *reason;
    Tcl_Size len;
    char flag = TCL_DONT_QUOTE_HASH;

    /*
     * Validate the property name. Note that just calling TclScanElement() is
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
int
TclOOInfoClassPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int all = 0, writable = 0, allocated = 0;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    for (int i = 2; i < objc; i++) {
	int idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	default:
	    TCL_UNREACHABLE();
	}
    }

    /*







|

















|


|


|







1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
int
TclOOInfoClassPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    bool all = false, writable = false, allocated = false;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    for (int i = 2; i < objc; i++) {
	int idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = true;
	    break;
	case PROP_READABLE:
	    writable = false;
	    break;
	case PROP_WRITABLE:
	    writable = true;
	    break;
	default:
	    TCL_UNREACHABLE();
	}
    }

    /*
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
int
TclOOInfoObjectPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int all = 0, writable = 0;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
	return TCL_ERROR;
    }
    Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    for (int i = 2; i < objc; i++) {
	int idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	default:
	    TCL_UNREACHABLE();
	}
    }

    /*







|

















|


|


|







1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
int
TclOOInfoObjectPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    bool all = false, writable = false;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
	return TCL_ERROR;
    }
    Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    for (int i = 2; i < objc; i++) {
	int idx;
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = true;
	    break;
	case PROP_READABLE:
	    writable = false;
	    break;
	case PROP_WRITABLE:
	    writable = true;
	    break;
	default:
	    TCL_UNREACHABLE();
	}
    }

    /*
Changes to generic/tclObj.c.
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include <assert.h>

/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)

/*
 * Head of the list of free Tcl_Obj structs we maintain.
 */

Tcl_Obj *tclFreeObjList = NULL;







|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
#include <assert.h>

/*
 * Table of all object types.
 */

static Tcl_HashTable typeTable;
static bool typeTableInitialized = false;
TCL_DECLARE_MUTEX(tableMutex)

/*
 * Head of the list of free Tcl_Obj structs we maintain.
 */

Tcl_Obj *tclFreeObjList = NULL;
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *-------------------------------------------------------------------------
 */

void
TclInitObjSubsystem(void)
{
    Tcl_MutexLock(&tableMutex);
    typeTableInitialized = 1;
    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&tableMutex);

    Tcl_RegisterObjType(&tclByteCodeType);
    Tcl_RegisterObjType(&tclCmdNameType);
    Tcl_RegisterObjType(&tclDictType);
    Tcl_RegisterObjType(&tclDoubleType);







|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 *-------------------------------------------------------------------------
 */

void
TclInitObjSubsystem(void)
{
    Tcl_MutexLock(&tableMutex);
    typeTableInitialized = true;
    Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
    Tcl_MutexUnlock(&tableMutex);

    Tcl_RegisterObjType(&tclByteCodeType);
    Tcl_RegisterObjType(&tclCmdNameType);
    Tcl_RegisterObjType(&tclDictType);
    Tcl_RegisterObjType(&tclDoubleType);
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471

void
TclFinalizeObjects(void)
{
    Tcl_MutexLock(&tableMutex);
    if (typeTableInitialized) {
	Tcl_DeleteHashTable(&typeTable);
	typeTableInitialized = 0;
    }
    Tcl_MutexUnlock(&tableMutex);

    /*
     * All we do here is reset the head pointer of the linked list of free
     * Tcl_Obj's to NULL; the memory finalization will take care of releasing
     * memory for us.







|







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471

void
TclFinalizeObjects(void)
{
    Tcl_MutexLock(&tableMutex);
    if (typeTableInitialized) {
	Tcl_DeleteHashTable(&typeTable);
	typeTableInitialized = false;
    }
    Tcl_MutexUnlock(&tableMutex);

    /*
     * All we do here is reset the head pointer of the linked list of free
     * Tcl_Obj's to NULL; the memory finalization will take care of releasing
     * memory for us.
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
    return TCL_ERROR;
}

static int
ParseBoolean(
    Tcl_Obj *objPtr)		/* The object to parse/convert. */
{
    int newBool;
    Tcl_Size length;
    const char *str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length < 1) || (length > 5)) {
	/*
	 * Longest valid boolean string rep. is "false".
	 */

	return TCL_ERROR;
    }

    switch (str[0]) {
    case '0':
	if (length == 1) {
	    newBool = 0;
	    goto numericBoolean;
	}
	return TCL_ERROR;
    case '1':
	if (length == 1) {
	    newBool = 1;
	    goto numericBoolean;
	}
	return TCL_ERROR;
    }

    /*
     * Force to lower case for case-insensitive detection. Filter out known







|














|





|







2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
    return TCL_ERROR;
}

static int
ParseBoolean(
    Tcl_Obj *objPtr)		/* The object to parse/convert. */
{
    bool newBool;
    Tcl_Size length;
    const char *str = Tcl_GetStringFromObj(objPtr, &length);

    if ((length < 1) || (length > 5)) {
	/*
	 * Longest valid boolean string rep. is "false".
	 */

	return TCL_ERROR;
    }

    switch (str[0]) {
    case '0':
	if (length == 1) {
	    newBool = false;
	    goto numericBoolean;
	}
	return TCL_ERROR;
    case '1':
	if (length == 1) {
	    newBool = true;
	    goto numericBoolean;
	}
	return TCL_ERROR;
    }

    /*
     * Force to lower case for case-insensitive detection. Filter out known
2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
    lowerCase[length] = 0;
    switch (lowerCase[0]) {
    case 'y':
	/*
	 * Checking the 'y' is redundant, but makes the code clearer.
	 */
	if (strncmp(lowerCase, "yes", length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'n':
	if (strncmp(lowerCase, "no", length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 't':
	if (strncmp(lowerCase, "true", length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'f':
	if (strncmp(lowerCase, "false", length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'o':
	if (length < 2) {
	    return TCL_ERROR;
	}
	if (strncmp(lowerCase, "on", length) == 0) {
	    newBool = 1;
	    goto goodBoolean;
	} else if (strncmp(lowerCase, "off", length) == 0) {
	    newBool = 0;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    default:
	return TCL_ERROR;
    }

    /*
     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

  goodBoolean:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

  numericBoolean:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = newBool;
    objPtr->typePtr = &tclIntType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|





|





|





|








|


|















|





|







2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
    lowerCase[length] = 0;
    switch (lowerCase[0]) {
    case 'y':
	/*
	 * Checking the 'y' is redundant, but makes the code clearer.
	 */
	if (strncmp(lowerCase, "yes", length) == 0) {
	    newBool = true;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'n':
	if (strncmp(lowerCase, "no", length) == 0) {
	    newBool = false;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 't':
	if (strncmp(lowerCase, "true", length) == 0) {
	    newBool = true;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'f':
	if (strncmp(lowerCase, "false", length) == 0) {
	    newBool = false;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    case 'o':
	if (length < 2) {
	    return TCL_ERROR;
	}
	if (strncmp(lowerCase, "on", length) == 0) {
	    newBool = true;
	    goto goodBoolean;
	} else if (strncmp(lowerCase, "off", length) == 0) {
	    newBool = false;
	    goto goodBoolean;
	}
	return TCL_ERROR;
    default:
	return TCL_ERROR;
    }

    /*
     * Free the old internalRep before setting the new one. We do this as late
     * as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */

  goodBoolean:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = (int) newBool;
    objPtr->typePtr = &tclBooleanType;
    return TCL_OK;

  numericBoolean:
    TclFreeInternalRep(objPtr);
    objPtr->internalRep.wideValue = (int) newBool;
    objPtr->typePtr = &tclIntType;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclParse.c.
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local functions defined in this file:
 */

static int		CommandComplete(const char *script, Tcl_Size numBytes);
static Tcl_Size		ParseComment(const char *src, Tcl_Size numBytes,
			    Tcl_Parse *parsePtr);
static int		ParseTokens(const char *src, Tcl_Size numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
static Tcl_Size		ParseWhiteSpace(const char *src, Tcl_Size numBytes,
			    int *incompletePtr, char *typePtr);
static Tcl_Size		ParseAllWhiteSpace(const char *src, Tcl_Size numBytes,







|







116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local functions defined in this file:
 */

static bool		CommandComplete(const char *script, Tcl_Size numBytes);
static Tcl_Size		ParseComment(const char *src, Tcl_Size numBytes,
			    Tcl_Parse *parsePtr);
static int		ParseTokens(const char *src, Tcl_Size numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
static Tcl_Size		ParseWhiteSpace(const char *src, Tcl_Size numBytes,
			    int *incompletePtr, char *typePtr);
static Tcl_Size		ParseAllWhiteSpace(const char *src, Tcl_Size numBytes,
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = start;
    parsePtr->end = start + numBytes;
    parsePtr->term = parsePtr->end;
    parsePtr->interp = interp;
    parsePtr->incomplete = 0;
    parsePtr->errorType = TCL_PARSE_SUCCESS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --







|







161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
    parsePtr->tokenPtr = parsePtr->staticTokens;
    parsePtr->numTokens = 0;
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = start;
    parsePtr->end = start + numBytes;
    parsePtr->term = parsePtr->end;
    parsePtr->interp = interp;
    parsePtr->incomplete = false;
    parsePtr->errorType = TCL_PARSE_SUCCESS;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
     * iteration through the loop.
     */

    parsePtr->commandStart = src;
    type = CHAR_TYPE(*src);
    scanned = 1;	/* Can't have missing whitepsace before first word. */
    while (1) {
	int expandWord = 0;

	/* Are we at command termination? */

	if ((numBytes == 0) || (type & terminators) != 0) {
	    parsePtr->term = src;
	    parsePtr->commandSize = src + (numBytes != 0)
		    - parsePtr->commandStart;







|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
     * iteration through the loop.
     */

    parsePtr->commandStart = src;
    type = CHAR_TYPE(*src);
    scanned = 1;	/* Can't have missing whitepsace before first word. */
    while (1) {
	bool expandWord = false;

	/* Are we at command termination? */

	if ((numBytes == 0) || (type & terminators) != 0) {
	    parsePtr->term = src;
	    parsePtr->commandSize = src + (numBytes != 0)
		    - parsePtr->commandStart;
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

	    /*
	     * Check whether the braces contained the word expansion prefix
	     * {*}
	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if ((0 == expandWord)
		    /* Haven't seen prefix already */
		    && (expIdx + 1 == parsePtr->numTokens)
		    /* Only one token */
		    && (((1 == expPtr->size)
			    /* Same length as prefix */
			    && (expPtr->start[0] == '*')))
			    /* Is the prefix */
		    && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
			    numBytes, &parsePtr->incomplete, &type))
		    && (type != TYPE_COMMAND_END)
		    /* Non-whitespace follows */) {
		expandWord = 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call ParseTokens and let it do all of
	     * the work.







|











|







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

	    /*
	     * Check whether the braces contained the word expansion prefix
	     * {*}
	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if (!expandWord
		    /* Haven't seen prefix already */
		    && (expIdx + 1 == parsePtr->numTokens)
		    /* Only one token */
		    && (((1 == expPtr->size)
			    /* Same length as prefix */
			    && (expPtr->start[0] == '*')))
			    /* Is the prefix */
		    && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
			    numBytes, &parsePtr->incomplete, &type))
		    && (type != TYPE_COMMAND_END)
		    /* Non-whitespace follows */) {
		expandWord = true;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call ParseTokens and let it do all of
	     * the work.
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
402
403
404
405
406
407
408
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if (expandWord) {
	    int isLiteral = 1;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
	     * caller might have to expand. This notably makes it simpler for
	     * those callers that wish to track line endings, such as those
	     * that implement key parts of TIP 280.
	     *
	     * First check whether the thing to be expanded is a literal,
	     * in the sense of being composed entirely of TCL_TOKEN_TEXT
	     * tokens.
	     */

	    for (Tcl_Size i = 1; i <= tokenPtr->numComponents; i++) {
		if (tokenPtr[i].type != TCL_TOKEN_TEXT) {
		    isLiteral = 0;
		    break;
		}
	    }

	    if (isLiteral) {
		Tcl_Size elemCount = 0;
		int code = TCL_OK, literal = 1;







|

















|







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
402
403
404
405
406
407
408
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if (expandWord) {
	    bool isLiteral = true;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
	     * caller might have to expand. This notably makes it simpler for
	     * those callers that wish to track line endings, such as those
	     * that implement key parts of TIP 280.
	     *
	     * First check whether the thing to be expanded is a literal,
	     * in the sense of being composed entirely of TCL_TOKEN_TEXT
	     * tokens.
	     */

	    for (Tcl_Size i = 1; i <= tokenPtr->numComponents; i++) {
		if (tokenPtr[i].type != TCL_TOKEN_TEXT) {
		    isLiteral = false;
		    break;
		}
	    }

	    if (isLiteral) {
		Tcl_Size elemCount = 0;
		int code = TCL_OK, literal = 1;
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554

555
556
557
558
559
560
561
 *
 * TclIsSpaceProc --
 *
 *	Report whether byte is in the set of whitespace characters used by
 *	Tcl to separate words in scripts or elements in lists.
 *
 * Results:
 *	Returns 1, if byte is in the set, 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclIsSpaceProc(
    int byte)
{
    return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n';
}

/*







|







<
>







539
540
541
542
543
544
545
546
547
548
549
550
551
552
553

554
555
556
557
558
559
560
561
 *
 * TclIsSpaceProc --
 *
 *	Report whether byte is in the set of whitespace characters used by
 *	Tcl to separate words in scripts or elements in lists.
 *
 * Results:
 *	Returns true if byte is in the set, false otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclIsSpaceProc(
    int byte)
{
    return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n';
}

/*
576
577
578
579
580
581
582
583

584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclIsBareword(
    int byte)
{
    if (byte < '0' || byte > 'z') {
	return 0;
    }
    if (byte <= '9' || byte >= 'a') {
	return 1;
    }
    if (byte == '_') {
	return 1;
    }
    if (byte < 'A' || byte > 'Z') {
	return 0;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseWhiteSpace --
 *







<
>




|


|


|


|

|







576
577
578
579
580
581
582

583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclIsBareword(
    int byte)
{
    if (byte < '0' || byte > 'z') {
	return false;
    }
    if (byte <= '9' || byte >= 'a') {
	return true;
    }
    if (byte == '_') {
	return true;
    }
    if (byte < 'A' || byte > 'Z') {
	return false;
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseWhiteSpace --
 *
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
		break;
	    }
	    if (p[1] != '\n') {
		break;
	    }
	    p += 2;
	    if (--numBytes == 0) {
		*incompletePtr = 1;
		break;
	    }
	    continue;
	}
	break;
    }
    *typePtr = type;







|







644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
		break;
	    }
	    if (p[1] != '\n') {
		break;
	    }
	    p += 2;
	    if (--numBytes == 0) {
		*incompletePtr = true;
		break;
	    }
	    continue;
	}
	break;
    }
    *typePtr = type;
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			TclPrintfResult(parsePtr->interp,
				"missing close-bracket");
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    TclStackFree(parsePtr->interp, nestedPtr);
		    return TCL_ERROR;
		}
	    }
	    TclStackFree(parsePtr->interp, nestedPtr);
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;







|







1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			TclPrintfResult(parsePtr->interp,
				"missing close-bracket");
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = true;
		    TclStackFree(parsePtr->interp, nestedPtr);
		    return TCL_ERROR;
		}
	    }
	    TclStackFree(parsePtr->interp, nestedPtr);
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
		src++;
		numBytes--;
		continue;
	    }

	    if (src[1] == '\n') {
		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}

		/*
		 * Note: backslash-newline is special in that it is treated
		 * the same as a space character would be. This means that it
		 * could terminate the token.
		 */







|







1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
		src++;
		numBytes--;
		continue;
	    }

	    if (src[1] == '\n') {
		if (numBytes == 2) {
		    parsePtr->incomplete = true;
		}

		/*
		 * Note: backslash-newline is special in that it is treated
		 * the same as a space character would be. This means that it
		 * could terminate the token.
		 */
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
	if (numBytes == 0) {
	    if (parsePtr->interp != NULL) {
		TclPrintfResult(parsePtr->interp,
			"missing close-brace for variable name");
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr[-1].size = src - tokenPtr[-1].start;
	parsePtr->numTokens++;
	src++;
    } else {







|







1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
	if (numBytes == 0) {
	    if (parsePtr->interp != NULL) {
		TclPrintfResult(parsePtr->interp,
			"missing close-brace for variable name");
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = true;
	    goto error;
	}
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr[-1].size = src - tokenPtr[-1].start;
	parsePtr->numTokens++;
	src++;
    } else {
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
	    }
	    if (parsePtr->term == src+numBytes){
		if (parsePtr->interp != NULL) {
		    TclPrintfResult(parsePtr->interp, "missing )");
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
		goto error;
	    } else if ((*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    TclPrintfResult(parsePtr->interp,
			    "invalid character in array index");
		}
		parsePtr->errorType = TCL_PARSE_SYNTAX;







|







1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
	    }
	    if (parsePtr->term == src+numBytes){
		if (parsePtr->interp != NULL) {
		    TclPrintfResult(parsePtr->interp, "missing )");
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = true;
		goto error;
	    } else if ((*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    TclPrintfResult(parsePtr->interp,
			    "invalid character in array index");
		}
		parsePtr->errorType = TCL_PARSE_SYNTAX;
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
		 * A backslash-newline sequence must be collapsed, even inside
		 * braces, so we have to split the word into multiple tokens
		 * so that the backslash-newline can be represented
		 * explicitly.
		 */

		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}
		tokenPtr->size = (src - tokenPtr->start);
		if (tokenPtr->size != 0) {
		    parsePtr->numTokens++;
		}
		TclGrowParseTokenArray(parsePtr, 2);
		tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];







|







1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
		 * A backslash-newline sequence must be collapsed, even inside
		 * braces, so we have to split the word into multiple tokens
		 * so that the backslash-newline can be represented
		 * explicitly.
		 */

		if (numBytes == 2) {
		    parsePtr->incomplete = true;
		}
		tokenPtr->size = (src - tokenPtr->start);
		if (tokenPtr->size != 0) {
		    parsePtr->numTokens++;
		}
		TclGrowParseTokenArray(parsePtr, 2);
		tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
	    break;
	}
    }

  missingBraceError:
    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
    parsePtr->term = start;
    parsePtr->incomplete = 1;
    if (parsePtr->interp == NULL) {
	/*
	 * Skip straight to the exit code since we have no interpreter to put
	 * error message in.
	 */

	goto error;
    }

    TclPrintfResult(parsePtr->interp, "missing close-brace");

    /*
     * Guess if the problem is due to comments by searching the source string
     * for a possible open brace within the context of a comment. Since we
     * aren't performing a full Tcl parse, just look for an open brace
     * preceded by a '<whitespace>#' on the same line.
     */

    {
	int openBrace = 0;

	while (--src > start) {
	    switch (*src) {
	    case '{':
		openBrace = 1;
		break;
	    case '\n':
		openBrace = 0;
		break;
	    case '#' :
		if (openBrace && TclIsSpaceProcM(src[-1])) {
		    TclAppendResult(parsePtr->interp,
			    ": possible unbalanced brace in comment");
		    goto error;
		}
		break;
	    }
	}
    }

  error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}







|


















<
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<







1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758

1759

1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774

1775
1776
1777
1778
1779
1780
1781
	    break;
	}
    }

  missingBraceError:
    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
    parsePtr->term = start;
    parsePtr->incomplete = true;
    if (parsePtr->interp == NULL) {
	/*
	 * Skip straight to the exit code since we have no interpreter to put
	 * error message in.
	 */

	goto error;
    }

    TclPrintfResult(parsePtr->interp, "missing close-brace");

    /*
     * Guess if the problem is due to comments by searching the source string
     * for a possible open brace within the context of a comment. Since we
     * aren't performing a full Tcl parse, just look for an open brace
     * preceded by a '<whitespace>#' on the same line.
     */


    bool openBrace = false;

    while (--src > start) {
	switch (*src) {
	case '{':
	    openBrace = true;
	    break;
	case '\n':
	    openBrace = false;
	    break;
	case '#' :
	    if (openBrace && TclIsSpaceProcM(src[-1])) {
		TclAppendResult(parsePtr->interp,
			": possible unbalanced brace in comment");
		goto error;
	    }
	    break;

	}
    }

  error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    TclPrintfResult(parsePtr->interp, "missing \"");
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = start;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;








|







1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    TclPrintfResult(parsePtr->interp, "missing \"");
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = start;
	parsePtr->incomplete = true;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;

1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
	 * Keep repeating until we get a good parse on a prefix.
	 */

	do {
	    parsePtr->numTokens = 0;
	    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	    parsePtr->end = parsePtr->term;
	    parsePtr->incomplete = 0;
	    parsePtr->errorType = TCL_PARSE_SUCCESS;
	} while (TCL_OK !=
		ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));

	/*
	 * The good parse will have to be followed by {, (, or [.
	 */







|







1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
	 * Keep repeating until we get a good parse on a prefix.
	 */

	do {
	    parsePtr->numTokens = 0;
	    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	    parsePtr->end = parsePtr->term;
	    parsePtr->incomplete = false;
	    parsePtr->errorType = TCL_PARSE_SUCCESS;
	} while (TCL_OK !=
		ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));

	/*
	 * The good parse will have to be followed by {, (, or [.
	 */
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
				 * command. See Tcl_EvalEx and TclEvalObjEx
				 * for the places generating arguments for
				 * which this is true. */
{
    Tcl_Obj *result;
    int code = TCL_OK;
#define NUM_STATIC_POS 20
    int isLiteral;
    Tcl_Size maxNumCL, numCL, adjust;
    Tcl_Size *clPosition = NULL;
    Interp *iPtr = (Interp *) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;

    /*
     * Each pass through this loop will substitute one token, and its







|







2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
				 * command. See Tcl_EvalEx and TclEvalObjEx
				 * for the places generating arguments for
				 * which this is true. */
{
    Tcl_Obj *result;
    int code = TCL_OK;
#define NUM_STATIC_POS 20
    bool isLiteral;
    Tcl_Size maxNumCL, numCL, adjust;
    Tcl_Size *clPosition = NULL;
    Interp *iPtr = (Interp *) interp;
    int inFile = iPtr->evalFlags & TCL_EVAL_FILE;

    /*
     * Each pass through this loop will substitute one token, and its
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
     * processing. Otherwise preallocate a small table to store the
     * locations of all continuation lines we find in this literal, if any.
     * The table is extended if needed.
     */

    numCL = 0;
    maxNumCL = 0;
    isLiteral = 1;
    for (Tcl_Size i=0 ; i < count; i++) {
	if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
		&& (tokenPtr[i].type != TCL_TOKEN_BS)) {
	    isLiteral = 0;
	    break;
	}
    }

    if (isLiteral) {
	maxNumCL = NUM_STATIC_POS;
	clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size));







|



|







2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
     * processing. Otherwise preallocate a small table to store the
     * locations of all continuation lines we find in this literal, if any.
     * The table is extended if needed.
     */

    numCL = 0;
    maxNumCL = 0;
    isLiteral = true;
    for (Tcl_Size i=0 ; i < count; i++) {
	if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
		&& (tokenPtr[i].type != TCL_TOKEN_BS)) {
	    isLiteral = false;
	    break;
	}
    }

    if (isLiteral) {
	maxNumCL = NUM_STATIC_POS;
	clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size));
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
 * CommandComplete --
 *
 *	This function is shared by TclCommandComplete and
 *	Tcl_ObjCommandComplete; it does all the real work of seeing whether a
 *	script is complete
 *
 * Results:
 *	1 is returned if the script is complete, 0 if there are open
 *	delimiters such as " or (. 1 is also returned if there is a parse
 *	error in the script other than unmatched delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(
    const char *script,		/* Script to check. */
    Tcl_Size numBytes)		/* Number of bytes in script. */
{
    Tcl_Parse parse;
    const char *p, *end;
    int result;

    p = script;
    end = p + numBytes;
    while (Tcl_ParseCommand(NULL, p, end - p, 0, &parse) == TCL_OK) {
	p = parse.commandStart + parse.commandSize;
	if (p >= end) {
	    break;
	}
	Tcl_FreeParse(&parse);
    }
    if (parse.incomplete) {
	result = 0;
    } else {
	result = 1;
    }
    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|
|








|






<










|
<
<
<
<







2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408

2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419




2420
2421
2422
2423
2424
2425
2426
 * CommandComplete --
 *
 *	This function is shared by TclCommandComplete and
 *	Tcl_ObjCommandComplete; it does all the real work of seeing whether a
 *	script is complete
 *
 * Results:
 *	true is returned if the script is complete, fa;se if there are open
 *	delimiters such as " or (. true is also returned if there is a parse
 *	error in the script other than unmatched delimiters.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
CommandComplete(
    const char *script,		/* Script to check. */
    Tcl_Size numBytes)		/* Number of bytes in script. */
{
    Tcl_Parse parse;
    const char *p, *end;


    p = script;
    end = p + numBytes;
    while (Tcl_ParseCommand(NULL, p, end - p, 0, &parse) == TCL_OK) {
	p = parse.commandStart + parse.commandSize;
	if (p >= end) {
	    break;
	}
	Tcl_FreeParse(&parse);
    }
    bool result = !parse.incomplete;




    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
Changes to generic/tclPathObj.c.
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
static Tcl_Obj *	AppendPath(Tcl_Obj *head, Tcl_Obj *tail);
static void		DupFsPathInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static void		FreeFsPathInternalRep(Tcl_Obj *pathPtr);
static void		UpdateStringOfFsPath(Tcl_Obj *pathPtr);
static int		SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Size		FindSplitPos(const char *path, int separator);
static int		IsSeparatorOrNull(int ch);
static Tcl_Obj *	GetExtension(Tcl_Obj *pathPtr);
static int		MakePathFromNormalized(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr);
static int		MakeTildeRelativePath(Tcl_Interp *interp,
			    const char *user, const char *subPath,
			    Tcl_DString *dsPtr);








|







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
static Tcl_Obj *	AppendPath(Tcl_Obj *head, Tcl_Obj *tail);
static void		DupFsPathInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static void		FreeFsPathInternalRep(Tcl_Obj *pathPtr);
static void		UpdateStringOfFsPath(Tcl_Obj *pathPtr);
static int		SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static Tcl_Size		FindSplitPos(const char *path, int separator);
static bool		IsSeparatorOrNull(int ch);
static Tcl_Obj *	GetExtension(Tcl_Obj *pathPtr);
static int		MakePathFromNormalized(Tcl_Interp *interp,
			    Tcl_Obj *pathPtr);
static int		MakeTildeRelativePath(Tcl_Interp *interp,
			    const char *user, const char *subPath,
			    Tcl_DString *dsPtr);

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

Tcl_Obj *
TclFSNormalizeAbsolutePath(
    Tcl_Interp *interp,		/* Interpreter to use */
    Tcl_Obj *pathPtr)		/* Absolute path to normalize */
{
    const char *dirSep, *oldDirSep;
    int first = 1;		/* Set to zero once we've passed the first
				 * directory separator - we can't use '..' to
				 * remove the volume in a path. */
    Tcl_Obj *retVal = NULL;
    int zipVolumeLen;
    dirSep = TclGetString(pathPtr);

    zipVolumeLen = TclIsZipfsPath(dirSep);







|







137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

Tcl_Obj *
TclFSNormalizeAbsolutePath(
    Tcl_Interp *interp,		/* Interpreter to use */
    Tcl_Obj *pathPtr)		/* Absolute path to normalize */
{
    const char *dirSep, *oldDirSep;
    bool first = true;		/* Set to false once we've passed the first
				 * directory separator - we can't use '..' to
				 * remove the volume in a path. */
    Tcl_Obj *retVal = NULL;
    int zipVolumeLen;
    dirSep = TclGetString(pathPtr);

    zipVolumeLen = TclIsZipfsPath(dirSep);
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

		if (dirSep[0] != 0 && dirSep[1] == '.') {
		    goto again;
		}
		continue;
	    }
	}
	first = 0;
	if (retVal != NULL) {
	    Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	}
    }

    /*
     * If we didn't make any changes, just use the input path.







|







358
359
360
361
362
363
364
365
366
367
368
369
370
371
372

		if (dirSep[0] != 0 && dirSep[1] == '.') {
		    goto again;
		}
		continue;
	    }
	}
	first = false;
	if (retVal != NULL) {
	    Tcl_AppendToObj(retVal, oldDirSep, dirSep - oldDirSep);
	}
    }

    /*
     * If we didn't make any changes, just use the input path.
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
    }

    /*
     * Ensure a windows drive like C:/ has a trailing separator.
     * Likewise for zipfs volumes.
     */
    if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
	int needTrailingSlash = 0;
	Tcl_Size len;
	const char *path = TclGetStringFromObj(retVal, &len);
	if (zipVolumeLen) {
	    if (len == (zipVolumeLen - 1)) {
		needTrailingSlash = 1;
	    }
	} else {
	    if (len == 2 && path[0] != 0 && path[1] == ':') {
		needTrailingSlash = 1;
	    }
	}
	if (needTrailingSlash) {
	    if (Tcl_IsShared(retVal)) {
		TclDecrRefCount(retVal);
		retVal = Tcl_DuplicateObj(retVal);
		Tcl_IncrRefCount(retVal);







|




|



|







396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
    }

    /*
     * Ensure a windows drive like C:/ has a trailing separator.
     * Likewise for zipfs volumes.
     */
    if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
	bool needTrailingSlash = false;
	Tcl_Size len;
	const char *path = TclGetStringFromObj(retVal, &len);
	if (zipVolumeLen) {
	    if (len == (zipVolumeLen - 1)) {
		needTrailingSlash = true;
	    }
	} else {
	    if (len == 2 && path[0] != 0 && path[1] == ':') {
		needTrailingSlash = true;
	    }
	}
	if (needTrailingSlash) {
	    if (Tcl_IsShared(retVal)) {
		TclDecrRefCount(retVal);
		retVal = Tcl_DuplicateObj(retVal);
		Tcl_IncrRefCount(retVal);
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

    if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
    TclListObjGetElements(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, 0);
    return res;
}

Tcl_Obj *
TclJoinPath(
    Tcl_Size elements,		/* Number of elements to use */
    Tcl_Obj * const objv[],	/* Path elements to join */
    int forceRelative)		/* If non-zero, assume all more paths are
				 * relative (e.g. simple normalization) */
{
    Tcl_Obj *res = NULL;
    const Tcl_Filesystem *fsPtr = NULL;

    if (elements == 0) {
	TclNewObj(res);
	return res;
    }

    assert ( elements > 0 );

    if (elements == 2) {
	Tcl_Obj *elt = objv[0];
	Tcl_ObjInternalRep *eltIr = TclFetchInternalRep(elt, &fsPathType);

	/*
	 * This is a special case where we can be much more efficient, where







|







|










|







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

    if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
    TclListObjGetElements(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, false);
    return res;
}

Tcl_Obj *
TclJoinPath(
    Tcl_Size elements,		/* Number of elements to use */
    Tcl_Obj * const objv[],	/* Path elements to join */
    bool forceRelative)		/* If true, assume all more paths are
				 * relative (e.g. simple normalization) */
{
    Tcl_Obj *res = NULL;
    const Tcl_Filesystem *fsPtr = NULL;

    if (elements == 0) {
	TclNewObj(res);
	return res;
    }

    assert(elements > 0);

    if (elements == 2) {
	Tcl_Obj *elt = objv[0];
	Tcl_ObjInternalRep *eltIr = TclFetchInternalRep(elt, &fsPathType);

	/*
	 * This is a special case where we can be much more efficient, where
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
			return tailObj;
		    }
		}
	    }
	}
    }

    assert ( res == NULL );

    for (Tcl_Size i = 0; i < elements; i++) {
	Tcl_Size driveNameLength;
	Tcl_Size strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;
	Tcl_Obj *driveName = NULL;







|







936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
			return tailObj;
		    }
		}
	    }
	}
    }

    assert(res == NULL);

    for (Tcl_Size i = 0; i < elements; i++) {
	Tcl_Size driveNameLength;
	Tcl_Size strEltLen, length;
	Tcl_PathType type;
	char *strElt, *ptr;
	Tcl_Obj *driveName = NULL;
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
	    continue;
	}

	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;

	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);

		if (sep != NULL) {
		    separator = TclGetString(sep)[0];
		    TclDecrRefCount(sep);







|







1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
	    continue;
	}

	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    bool needsSep = false;

	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);

		if (sep != NULL) {
		    separator = TclGetString(sep)[0];
		    TclDecrRefCount(sep);
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
		    if (strElt[1] != '\0') {
			if (needsSep) {
			    *ptr++ = separator;
			}
		    }
		} else {
		    *ptr++ = *strElt;
		    needsSep = 1;
		}
	    }
	    length = ptr - TclGetString(res);
	    Tcl_SetObjLength(res, length);
	}
    }
    assert ( res != NULL );







|







1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
		    if (strElt[1] != '\0') {
			if (needsSep) {
			    *ptr++ = separator;
			}
		    }
		} else {
		    *ptr++ = *strElt;
		    needsSep = true;
		}
	    }
	    length = ptr - TclGetString(res);
	    Tcl_SetObjLength(res, length);
	}
    }
    assert ( res != NULL );
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
    return SetFsPathFromAny(interp, pathPtr);
}

/*
 * Helper function for normalization.
 */

static int
IsSeparatorOrNull(
    int ch)
{
    if (ch == 0) {
	return 1;
    }
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	return (ch == '/' ? 1 : 0);
    case TCL_PLATFORM_WINDOWS:
	return ((ch == '/' || ch == '\\') ? 1 : 0);
    }
    return 0;
}

/*
 * Helper function for SetFsPathFromAny. Returns position of first directory
 * delimiter in the path. If no separator is found, then returns the position
 * of the end of the string.
 */







|




|



|

|

|







1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
    return SetFsPathFromAny(interp, pathPtr);
}

/*
 * Helper function for normalization.
 */

static bool
IsSeparatorOrNull(
    int ch)
{
    if (ch == 0) {
	return true;
    }
    switch (tclPlatform) {
    case TCL_PLATFORM_UNIX:
	return (ch == '/');
    case TCL_PLATFORM_WINDOWS:
	return (ch == '/' || ch == '\\');
    }
    return false;
}

/*
 * Helper function for SetFsPathFromAny. Returns position of first directory
 * delimiter in the path. If no separator is found, then returns the position
 * of the end of the string.
 */
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
    Tcl_Obj *dirPtr,
    const char *addStrRep,
    Tcl_Size len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    const char *p;
    int state = 0, count = 0;

    /*
     * This comment is kept from the days of tilde expansion because
     * it is illustrative of a more general problem.
     * [Bug 2806250] - this is only a partial solution of the problem.
     * The PATHFLAGS != 0 representation assumes in many places that
     * the "tail" part stored in the normPathPtr field is itself a







|







1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
    Tcl_Obj *dirPtr,
    const char *addStrRep,
    Tcl_Size len)
{
    FsPath *fsPathPtr;
    Tcl_Obj *pathPtr;
    const char *p;
    bool state = false, count = false;

    /*
     * This comment is kept from the days of tilde expansion because
     * it is illustrative of a more general problem.
     * [Bug 2806250] - this is only a partial solution of the problem.
     * The PATHFLAGS != 0 representation assumes in many places that
     * the "tail" part stored in the normPathPtr field is itself a
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
     * Look for path components made up of only "."
     * This is overly conservative analysis to keep simple. It may mark some
     * things as needing more aggressive normalization that don't actually
     * need it. No harm done.
     */
    for (p = addStrRep; len > 0; p++, len--) {
	switch (state) {
	case 0:		/* So far only "." since last dirsep or start */
	    switch (*p) {
	    case '.':
		count = 1;
		break;
	    case '/':
	    case '\\':
	    case ':':
		if (count) {
		    PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
		    len = 0;
		}
		break;
	    default:
		count = 0;
		state = 1;
	    }
	    break;
	case 1:		/* Scanning for next dirsep */
	    switch (*p) {
	    case '/':
	    case '\\':
	    case ':':
		state = 0;
		break;
	    }
	}
    }
    if (len == 0 && count) {
	PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
    }







|


|










|
|


|




|







1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
     * Look for path components made up of only "."
     * This is overly conservative analysis to keep simple. It may mark some
     * things as needing more aggressive normalization that don't actually
     * need it. No harm done.
     */
    for (p = addStrRep; len > 0; p++, len--) {
	switch (state) {
	case false:	/* So far only "." since last dirsep or start */
	    switch (*p) {
	    case '.':
		count = true;
		break;
	    case '/':
	    case '\\':
	    case ':':
		if (count) {
		    PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
		    len = 0;
		}
		break;
	    default:
		count = false;
		state = true;
	    }
	    break;
	case true:	/* Scanning for next dirsep */
	    switch (*p) {
	    case '/':
	    case '\\':
	    case ':':
		state = false;
		break;
	    }
	}
    }
    if (len == 0 && count) {
	PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
    }
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
    Tcl_Obj *secondPtr)
{
    const char *firstStr, *secondStr;
    Tcl_Size firstLen, secondLen;
    int tempErrno;

    if (firstPtr == secondPtr) {
	return 1;
    }

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }
    firstStr = TclGetStringFromObj(firstPtr, &firstLen);
    secondStr = TclGetStringFromObj(secondPtr, &secondLen);
    if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
	return 1;
    }

    /*
     * Try the most thorough, correct method of comparing fully normalized
     * paths.
     */

    tempErrno = Tcl_GetErrno();
    firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
    secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
    Tcl_SetErrno(tempErrno);

    if (firstPtr == NULL || secondPtr == NULL) {
	return 0;
    }

    firstStr = TclGetStringFromObj(firstPtr, &firstLen);
    secondStr = TclGetStringFromObj(secondPtr, &secondLen);
    return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}








|



|




|













|







2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
    Tcl_Obj *secondPtr)
{
    const char *firstStr, *secondStr;
    Tcl_Size firstLen, secondLen;
    int tempErrno;

    if (firstPtr == secondPtr) {
	return true;
    }

    if (firstPtr == NULL || secondPtr == NULL) {
	return false;
    }
    firstStr = TclGetStringFromObj(firstPtr, &firstLen);
    secondStr = TclGetStringFromObj(secondPtr, &secondLen);
    if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
	return true;
    }

    /*
     * Try the most thorough, correct method of comparing fully normalized
     * paths.
     */

    tempErrno = Tcl_GetErrno();
    firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
    secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
    Tcl_SetErrno(tempErrno);

    if (firstPtr == NULL || secondPtr == NULL) {
	return false;
    }

    firstStr = TclGetStringFromObj(firstPtr, &firstLen);
    secondStr = TclGetStringFromObj(secondPtr, &secondLen);
    return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}

2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
     *
     * However, the split/join routines are quite complex, and one has to make
     * sure not to break anything on Unix or Win (fCmd.test, fileName.test and
     * cmdAH.test exercise most of the code).
     */

    TclGetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
    transPtr = TclJoinPath(1, &pathPtr, 1);

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */

    fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath));







|







2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
     *
     * However, the split/join routines are quite complex, and one has to make
     * sure not to break anything on Unix or Win (fCmd.test, fileName.test and
     * cmdAH.test exercise most of the code).
     */

    TclGetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
    transPtr = TclJoinPath(1, &pathPtr, true);

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */

    fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath));
Changes to generic/tclPipe.c.
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
TCL_DECLARE_MUTEX(pipeMutex)	/* Guard access to detList. */

/*
 * Declarations for local functions defined in this file:
 */

static TclFile		FileForRedirect(Tcl_Interp *interp, const char *spec,
			    int atOk, const char *arg, const char *nextArg,
			    int flags, int *skipPtr, int *closePtr,
			    int *releasePtr);

/*
 *----------------------------------------------------------------------
 *
 * FileForRedirect --
 *
 *	This function does much of the work of parsing redirection operators.







|
|
|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
TCL_DECLARE_MUTEX(pipeMutex)	/* Guard access to detList. */

/*
 * Declarations for local functions defined in this file:
 */

static TclFile		FileForRedirect(Tcl_Interp *interp, const char *spec,
			    bool atOK, const char *arg, const char *nextArg,
			    int flags, int *skipPtr, bool *closePtr,
			    bool *releasePtr);

/*
 *----------------------------------------------------------------------
 *
 * FileForRedirect --
 *
 *	This function does much of the work of parsing redirection operators.
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
 */

static TclFile
FileForRedirect(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    const char *spec,		/* Points to character just after redirection
				 * character. */
    int atOK,			/* Non-zero means that '@' notation can be
				 * used to specify a channel, zero means that
				 * it isn't. */
    const char *arg,		/* Pointer to entire argument containing spec:
				 * used for error reporting. */
    const char *nextArg,	/* Next argument in argc/argv array, if needed
				 * for file name or channel name. May be
				 * NULL. */
    int flags,			/* Flags to use for opening file or to specify
				 * mode for channel. */
    int *skipPtr,		/* Filled with 1 if redirection target was in
				 * spec, 2 if it was in nextArg. */
    int *closePtr,		/* Filled with one if the caller should close
				 * the file when done with it, zero
				 * otherwise. */
    int *releasePtr)
{
    int writing = (flags & O_WRONLY);
    Tcl_Channel chan;
    TclFile file;

    *skipPtr = 1;
    if ((atOK != 0) && (*spec == '@')) {
	spec++;
	if (*spec == '\0') {
	    spec = nextArg;
	    if (spec == NULL) {
		goto badLastArg;
	    }
	    *skipPtr = 2;







|
|










|


|

|




|







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
 */

static TclFile
FileForRedirect(
    Tcl_Interp *interp,		/* Interpreter to use for error reporting. */
    const char *spec,		/* Points to character just after redirection
				 * character. */
    bool atOK,			/* True means that '@' notation can be
				 * used to specify a channel, false means that
				 * it isn't. */
    const char *arg,		/* Pointer to entire argument containing spec:
				 * used for error reporting. */
    const char *nextArg,	/* Next argument in argc/argv array, if needed
				 * for file name or channel name. May be
				 * NULL. */
    int flags,			/* Flags to use for opening file or to specify
				 * mode for channel. */
    int *skipPtr,		/* Filled with 1 if redirection target was in
				 * spec, 2 if it was in nextArg. */
    bool *closePtr,		/* Filled with one if the caller should close
				 * the file when done with it, zero
				 * otherwise. */
    bool *releasePtr)
{
    bool writing = (flags & O_WRONLY);
    Tcl_Channel chan;
    TclFile file;

    *skipPtr = 1;
    if (atOK && (*spec == '@')) {
	spec++;
	if (*spec == '\0') {
	    spec = nextArg;
	    if (spec == NULL) {
		goto badLastArg;
	    }
	    *skipPtr = 2;
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
		TclPrintfResult(interp, "channel \"%s\" wasn't opened for %s",
			TclGetChannelName(chan),
			(writing ? "writing" : "reading"));
		TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADCHAN");
	    }
	    return NULL;
	}
	*releasePtr = 1;
	if (writing) {
	    /*
	     * Be sure to flush output to the file, so that anything written
	     * by the child appears after stuff we've already written.
	     */

	    Tcl_Flush(chan);







|







109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
		TclPrintfResult(interp, "channel \"%s\" wasn't opened for %s",
			TclGetChannelName(chan),
			(writing ? "writing" : "reading"));
		TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC", "BADCHAN");
	    }
	    return NULL;
	}
	*releasePtr = true;
	if (writing) {
	    /*
	     * Be sure to flush output to the file, so that anything written
	     * by the child appears after stuff we've already written.
	     */

	    Tcl_Flush(chan);
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
	Tcl_DStringFree(&nameString);
	if (file == NULL) {
	    TclPrintfResult(interp, "couldn't %s file \"%s\": %s",
		    (writing ? "write" : "read"), spec,
		    Tcl_PosixError(interp));
	    return NULL;
	}
	*closePtr = 1;
    }
    return file;

  badLastArg:
    TclPrintfResult(interp,
	    "can't specify \"%s\" as last word in command", arg);
    TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX");







|







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
	Tcl_DStringFree(&nameString);
	if (file == NULL) {
	    TclPrintfResult(interp, "couldn't %s file \"%s\": %s",
		    (writing ? "write" : "read"), spec,
		    Tcl_PosixError(interp));
	    return NULL;
	}
	*closePtr = true;
    }
    return file;

  badLastArg:
    TclPrintfResult(interp,
	    "can't specify \"%s\" as last word in command", arg);
    TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX");
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
    Tcl_Interp *interp,		/* Used for error messages. */
    Tcl_Size numPids,		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr,		/* Array of process ids of children. */
    Tcl_Channel errorChan)	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int code, abnormalExit, anyErrorInfo;
    TclProcessWaitStatus waitStatus;
    Tcl_Obj *msg, *error;

    abnormalExit = 0;
    for (Tcl_Size i = 0; i < numPids; i++) {
	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
	if (waitStatus == TCL_PROCESS_ERROR) {
	    result = TCL_ERROR;
	    if (interp != NULL) {
		Tcl_SetObjErrorCode(interp, error);
		Tcl_SetObjResult(interp, msg);







|
|



|







261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
    Tcl_Interp *interp,		/* Used for error messages. */
    Tcl_Size numPids,		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr,		/* Array of process ids of children. */
    Tcl_Channel errorChan)	/* Channel for file containing stderr output
				 * from pipeline. NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK, code;
    bool abnormalExit, anyErrorInfo;
    TclProcessWaitStatus waitStatus;
    Tcl_Obj *msg, *error;

    abnormalExit = false;
    for (Tcl_Size i = 0; i < numPids; i++) {
	waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
	if (waitStatus == TCL_PROCESS_ERROR) {
	    result = TCL_ERROR;
	    if (interp != NULL) {
		Tcl_SetObjErrorCode(interp, error);
		Tcl_SetObjResult(interp, msg);
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

	if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
	    result = TCL_ERROR;
	    if (waitStatus == TCL_PROCESS_EXITED) {
		if (interp != NULL) {
		    Tcl_SetObjErrorCode(interp, error);
		}
		abnormalExit = 1;
	    } else if (interp != NULL) {
		Tcl_SetObjErrorCode(interp, error);
		Tcl_SetObjResult(interp, msg);
	    }
	    Tcl_DecrRefCount(error);
	    Tcl_DecrRefCount(msg);
	}
    }

    /*
     * Read the standard error file. If there's anything there, then return an
     * error and add the file's contents to the result string.
     */

    anyErrorInfo = 0;
    if (errorChan != NULL) {
	/*
	 * Make sure we start at the beginning of the file.
	 */

	if (interp != NULL) {
	    Tcl_Size count;
	    Tcl_Obj *objPtr;

	    Tcl_Seek(errorChan, 0, SEEK_SET);
	    TclNewObj(objPtr);
	    count = Tcl_ReadChars(errorChan, objPtr, TCL_INDEX_NONE, 0);
	    if (count == -1) {
		result = TCL_ERROR;
		Tcl_DecrRefCount(objPtr);
		Tcl_ResetResult(interp);
		TclPrintfResult(interp, "error reading stderr output file: %s",
			Tcl_PosixError(interp));
	    } else if (count > 0) {
		anyErrorInfo = 1;
		Tcl_SetObjResult(interp, objPtr);
		result = TCL_ERROR;
	    } else {
		Tcl_DecrRefCount(objPtr);
	    }
	}
	Tcl_CloseEx(NULL, errorChan, 0);
    }

    /*
     * If a child exited abnormally but didn't output any error information at
     * all, generate an error message here.
     */

    if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
	TclPrintfResult(interp, "child process exited abnormally");
    }
    return result;
}

/*
 *----------------------------------------------------------------------







|














|



















|














|







293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

	if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
	    result = TCL_ERROR;
	    if (waitStatus == TCL_PROCESS_EXITED) {
		if (interp != NULL) {
		    Tcl_SetObjErrorCode(interp, error);
		}
		abnormalExit = true;
	    } else if (interp != NULL) {
		Tcl_SetObjErrorCode(interp, error);
		Tcl_SetObjResult(interp, msg);
	    }
	    Tcl_DecrRefCount(error);
	    Tcl_DecrRefCount(msg);
	}
    }

    /*
     * Read the standard error file. If there's anything there, then return an
     * error and add the file's contents to the result string.
     */

    anyErrorInfo = false;
    if (errorChan != NULL) {
	/*
	 * Make sure we start at the beginning of the file.
	 */

	if (interp != NULL) {
	    Tcl_Size count;
	    Tcl_Obj *objPtr;

	    Tcl_Seek(errorChan, 0, SEEK_SET);
	    TclNewObj(objPtr);
	    count = Tcl_ReadChars(errorChan, objPtr, TCL_INDEX_NONE, 0);
	    if (count == -1) {
		result = TCL_ERROR;
		Tcl_DecrRefCount(objPtr);
		Tcl_ResetResult(interp);
		TclPrintfResult(interp, "error reading stderr output file: %s",
			Tcl_PosixError(interp));
	    } else if (count > 0) {
		anyErrorInfo = true;
		Tcl_SetObjResult(interp, objPtr);
		result = TCL_ERROR;
	    } else {
		Tcl_DecrRefCount(objPtr);
	    }
	}
	Tcl_CloseEx(NULL, errorChan, 0);
    }

    /*
     * If a child exited abnormally but didn't output any error information at
     * all, generate an error message here.
     */

    if (abnormalExit && !anyErrorInfo && (interp != NULL)) {
	TclPrintfResult(interp, "child process exited abnormally");
    }
    return result;
}

/*
 *----------------------------------------------------------------------
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450

451
452
453
454
455
456
457
458
459
460
461
				/* If non-null, then this points to a string
				 * containing input data (specified via <<) to
				 * be piped to the first process in the
				 * pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for
				 * first process in pipeline (specified via <
				 * or <@). */
    int inputClose = 0;		/* If non-zero, then inputFile should be
				 * closed when cleaning up. */
    int inputRelease = 0;
    TclFile outputFile = NULL;	/* Writable file for output from last command
				 * in pipeline (could be file or pipe). NULL
				 * means use stdout. */
    int outputClose = 0;	/* If non-zero, then outputFile should be
				 * closed when cleaning up. */
    int outputRelease = 0;
    TclFile errorFile = NULL;	/* Writable file for error output from all
				 * commands in pipeline. NULL means use
				 * stderr. */
    int errorClose = 0;		/* If non-zero, then errorFile should be
				 * closed when cleaning up. */
    int errorRelease = 0;
    const char *p;
    const char *nextArg;
    int skip, atOK, flags, needCmd, errorToOutput = 0;

    Tcl_Size lastArg, lastBar;
    Tcl_DString execBuffer;
    TclFile pipeIn;
    TclFile curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {
	*inPipePtr = NULL;
    }
    if (outPipePtr != NULL) {
	*outPipePtr = NULL;







|

|



|

|



|

|
|
<
|
>


<
|







426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448

449
450
451
452

453
454
455
456
457
458
459
460
				/* If non-null, then this points to a string
				 * containing input data (specified via <<) to
				 * be piped to the first process in the
				 * pipeline. */
    TclFile inputFile = NULL;	/* If != NULL, gives file to use as input for
				 * first process in pipeline (specified via <
				 * or <@). */
    bool inputClose = false;	/* If non-zero, then inputFile should be
				 * closed when cleaning up. */
    bool inputRelease = false;
    TclFile outputFile = NULL;	/* Writable file for output from last command
				 * in pipeline (could be file or pipe). NULL
				 * means use stdout. */
    bool outputClose = false;	/* If non-zero, then outputFile should be
				 * closed when cleaning up. */
    bool outputRelease = false;
    TclFile errorFile = NULL;	/* Writable file for error output from all
				 * commands in pipeline. NULL means use
				 * stderr. */
    bool errorClose = false;	/* If non-zero, then errorFile should be
				 * closed when cleaning up. */
    bool errorRelease = false;
    const char *p, *nextArg;

    int skip, flags, errorToOutput = 0;
    bool atOK, needCmd;
    Tcl_Size lastArg, lastBar;
    Tcl_DString execBuffer;

    TclFile pipeIn, curInFile, curOutFile, curErrFile;
    Tcl_Channel channel;

    if (inPipePtr != NULL) {
	*inPipePtr = NULL;
    }
    if (outPipePtr != NULL) {
	*outPipePtr = NULL;
482
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;
    cmdCount = 1;
    needCmd = 1;
    for (Tcl_Size i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    TclPrintfResult(interp, "illegal use of | or |& in command");
		    TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC",
			    "PIPESYNTAX");
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;
	    needCmd = 1;
	    break;

	case '<':
	    if (inputClose != 0) {
		inputClose = 0;
		TclpCloseFile(inputFile);
	    }
	    if (inputRelease != 0) {
		inputRelease = 0;
		TclpReleaseFile(inputFile);
	    }
	    if (*p == '<') {
		inputFile = NULL;
		inputLiteral = p + 1;
		skip = 1;
		if (*inputLiteral == '\0') {







|



















|



|
|


|
|







481
482
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
     * appear anywhere in the command line - e.g., the '<' that specifies the
     * input to the entire pipe may appear at the very end of the argument
     * list.
     */

    lastBar = -1;
    cmdCount = 1;
    needCmd = true;
    for (Tcl_Size i = 0; i < argc; i++) {
	errorToOutput = 0;
	skip = 0;
	p = argv[i];
	switch (*p++) {
	case '|':
	    if (*p == '&') {
		p++;
	    }
	    if (*p == '\0') {
		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
		    TclPrintfResult(interp, "illegal use of | or |& in command");
		    TclSetErrorCode(interp, "TCL", "OPERATION", "EXEC",
			    "PIPESYNTAX");
		    goto error;
		}
	    }
	    lastBar = i;
	    cmdCount++;
	    needCmd = true;
	    break;

	case '<':
	    if (inputClose) {
		inputClose = false;
		TclpCloseFile(inputFile);
	    }
	    if (inputRelease) {
		inputRelease = false;
		TclpReleaseFile(inputFile);
	    }
	    if (*p == '<') {
		inputFile = NULL;
		inputLiteral = p + 1;
		skip = 1;
		if (*inputLiteral == '\0') {
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
		if (inputFile == NULL) {
		    goto error;
		}
	    }
	    break;

	case '>':
	    atOK = 1;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = 0;

		/*
		 * Note that the O_APPEND flag only has an effect on POSIX
		 * platforms. On Windows, we just have to carry on regardless.
		 */

		flags = O_WRONLY | O_CREAT | O_APPEND;
	    }
	    if (*p == '&') {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);
		}
		errorToOutput = 1;
		p++;
	    }

	    /*
	     * Close the old output file, but only if the error file is not
	     * also using it.
	     */

	    if (outputClose != 0) {
		outputClose = 0;
		if (errorFile == outputFile) {
		    errorClose = 1;
		} else {
		    TclpCloseFile(outputFile);
		}
	    }
	    if (outputRelease != 0) {
		outputRelease = 0;
		if (errorFile == outputFile) {
		    errorRelease = 1;
		} else {
		    TclpReleaseFile(outputFile);
		}
	    }
	    nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
	    outputFile = FileForRedirect(interp, p, atOK, argv[i], nextArg,
		    flags, &skip, &outputClose, &outputRelease);
	    if (outputFile == NULL) {
		goto error;
	    }
	    if (errorToOutput) {
		if (errorClose != 0) {
		    errorClose = 0;
		    TclpCloseFile(errorFile);
		}
		if (errorRelease != 0) {
		    errorRelease = 0;
		    TclpReleaseFile(errorFile);
		}
		errorFile = outputFile;
	    }
	    break;

	case '2':
	    if (*p != '>') {
		break;
	    }
	    p++;
	    atOK = 1;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = 0;

		/*
		 * Note that the O_APPEND flag only has an effect on POSIX
		 * platforms. On Windows, we just have to carry on regardless.
		 */

		flags = O_WRONLY | O_CREAT | O_APPEND;
	    }
	    if (errorClose != 0) {
		errorClose = 0;
		TclpCloseFile(errorFile);
	    }
	    if (errorRelease != 0) {
		errorRelease = 0;
		TclpReleaseFile(errorFile);
	    }
	    if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
		/*
		 * Special case handling of 2>@1 to redirect stderr to the
		 * exec/open output pipe as well. This is meant for the end of
		 * the command string, otherwise use |& between commands.







|



|










|











|
|

|




|
|

|











|
|


|
|











|



|








|
|


|
|







541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
		if (inputFile == NULL) {
		    goto error;
		}
	    }
	    break;

	case '>':
	    atOK = true;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = false;

		/*
		 * Note that the O_APPEND flag only has an effect on POSIX
		 * platforms. On Windows, we just have to carry on regardless.
		 */

		flags = O_WRONLY | O_CREAT | O_APPEND;
	    }
	    if (*p == '&') {
		if (errorClose != 0) {
		    errorClose = false;
		    TclpCloseFile(errorFile);
		}
		errorToOutput = 1;
		p++;
	    }

	    /*
	     * Close the old output file, but only if the error file is not
	     * also using it.
	     */

	    if (outputClose) {
		outputClose = false;
		if (errorFile == outputFile) {
		    errorClose = true;
		} else {
		    TclpCloseFile(outputFile);
		}
	    }
	    if (outputRelease) {
		outputRelease = false;
		if (errorFile == outputFile) {
		    errorRelease = true;
		} else {
		    TclpReleaseFile(outputFile);
		}
	    }
	    nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
	    outputFile = FileForRedirect(interp, p, atOK, argv[i], nextArg,
		    flags, &skip, &outputClose, &outputRelease);
	    if (outputFile == NULL) {
		goto error;
	    }
	    if (errorToOutput) {
		if (errorClose) {
		    errorClose = false;
		    TclpCloseFile(errorFile);
		}
		if (errorRelease) {
		    errorRelease = false;
		    TclpReleaseFile(errorFile);
		}
		errorFile = outputFile;
	    }
	    break;

	case '2':
	    if (*p != '>') {
		break;
	    }
	    p++;
	    atOK = true;
	    flags = O_WRONLY | O_CREAT | O_TRUNC;
	    if (*p == '>') {
		p++;
		atOK = false;

		/*
		 * Note that the O_APPEND flag only has an effect on POSIX
		 * platforms. On Windows, we just have to carry on regardless.
		 */

		flags = O_WRONLY | O_CREAT | O_APPEND;
	    }
	    if (errorClose) {
		errorClose = false;
		TclpCloseFile(errorFile);
	    }
	    if (errorRelease) {
		errorRelease = false;
		TclpReleaseFile(errorFile);
	    }
	    if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
		/*
		 * Special case handling of 2>@1 to redirect stderr to the
		 * exec/open output pipe as well. This is meant for the end of
		 * the command string, otherwise use |& between commands.
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
	    break;

	default:
	    /*
	     * Got a command word, not a redirection.
	     */

	    needCmd = 0;
	    break;
	}

	if (skip != 0) {
	    for (Tcl_Size j = i + skip; j < argc; j++) {
		argv[j - skip] = argv[j];
	    }







|







662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
	    break;

	default:
	    /*
	     * Got a command word, not a redirection.
	     */

	    needCmd = false;
	    break;
	}

	if (skip != 0) {
	    for (Tcl_Size j = i + skip; j < argc; j++) {
		argv[j - skip] = argv[j];
	    }
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
	    inputFile = TclpCreateTempFile(inputLiteral);
	    if (inputFile == NULL) {
		TclPrintfResult(interp,
			"couldn't create input file for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    inputClose = 1;
	} else if (inPipePtr != NULL) {
	    /*
	     * The input for the first process in the pipeline is to come from
	     * a pipe that can be written from by the caller.
	     */

	    if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
		TclPrintfResult(interp,
			"couldn't create input pipe for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    inputClose = 1;
	} else {
	    /*
	     * The input for the first process comes from stdin.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDIN);
	    if (channel != NULL) {
		inputFile = TclpMakeFile(channel, TCL_READABLE);
		if (inputFile != NULL) {
		    inputRelease = 1;
		}
	    }
	}
    }

    if (outputFile == NULL) {
	if (outPipePtr != NULL) {
	    /*
	     * Output from the last process in the pipeline is to go to a pipe
	     * that can be read by the caller.
	     */

	    if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
		TclPrintfResult(interp,
			"couldn't create output pipe for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    outputClose = 1;
	} else {
	    /*
	     * The output for the last process goes to stdout.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDOUT);
	    if (channel) {
		outputFile = TclpMakeFile(channel, TCL_WRITABLE);
		if (outputFile != NULL) {
		    outputRelease = 1;
		}
	    }
	}
    }

    if (errorFile == NULL) {
	if (errorToOutput == 2) {







|












|









|


















|









|







700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
	    inputFile = TclpCreateTempFile(inputLiteral);
	    if (inputFile == NULL) {
		TclPrintfResult(interp,
			"couldn't create input file for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    inputClose = true;
	} else if (inPipePtr != NULL) {
	    /*
	     * The input for the first process in the pipeline is to come from
	     * a pipe that can be written from by the caller.
	     */

	    if (TclpCreatePipe(&inputFile, inPipePtr) == 0) {
		TclPrintfResult(interp,
			"couldn't create input pipe for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    inputClose = true;
	} else {
	    /*
	     * The input for the first process comes from stdin.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDIN);
	    if (channel != NULL) {
		inputFile = TclpMakeFile(channel, TCL_READABLE);
		if (inputFile != NULL) {
		    inputRelease = true;
		}
	    }
	}
    }

    if (outputFile == NULL) {
	if (outPipePtr != NULL) {
	    /*
	     * Output from the last process in the pipeline is to go to a pipe
	     * that can be read by the caller.
	     */

	    if (TclpCreatePipe(outPipePtr, &outputFile) == 0) {
		TclPrintfResult(interp,
			"couldn't create output pipe for command: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	    outputClose = true;
	} else {
	    /*
	     * The output for the last process goes to stdout.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDOUT);
	    if (channel) {
		outputFile = TclpMakeFile(channel, TCL_WRITABLE);
		if (outputFile != NULL) {
		    outputRelease = true;
		}
	    }
	}
    }

    if (errorFile == NULL) {
	if (errorToOutput == 2) {
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
	     * Errors from the pipeline go to stderr.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDERR);
	    if (channel) {
		errorFile = TclpMakeFile(channel, TCL_WRITABLE);
		if (errorFile != NULL) {
		    errorRelease = 1;
		}
	    }
	}
    }

    /*
     * Scan through the argc array, creating a process for each group of
     * arguments between the "|" characters.
     */

    Tcl_ReapDetachedProcs();
    pidPtr = (Tcl_Pid *)Tcl_Alloc(cmdCount * sizeof(Tcl_Pid));

    curInFile = inputFile;

    for (Tcl_Size i = 0; i < argc; i = lastArg + 1) {
	int result, joinThisError;

	Tcl_Pid pid;
	const char *oldName;

	/*
	 * Convert the program name into native form.
	 */

	if (Tcl_TranslateFileName(interp, argv[i], &execBuffer) == NULL) {
	    goto error;
	}

	/*
	 * Find the end of the current segment of the pipeline.
	 */

	joinThisError = 0;
	for (lastArg = i; lastArg < argc; lastArg++) {
	    if (argv[lastArg][0] != '|') {
		continue;
	    }
	    if (argv[lastArg][1] == '\0') {
		break;
	    }
	    if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
		joinThisError = 1;
		break;
	    }
	}

	/*
	 * If this is the last segment, use the specified outputFile.
	 * Otherwise create an intermediate pipe. pipeIn will become the







|
















|
>















|








|







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
	     * Errors from the pipeline go to stderr.
	     */

	    channel = Tcl_GetStdChannel(TCL_STDERR);
	    if (channel) {
		errorFile = TclpMakeFile(channel, TCL_WRITABLE);
		if (errorFile != NULL) {
		    errorRelease = true;
		}
	    }
	}
    }

    /*
     * Scan through the argc array, creating a process for each group of
     * arguments between the "|" characters.
     */

    Tcl_ReapDetachedProcs();
    pidPtr = (Tcl_Pid *)Tcl_Alloc(cmdCount * sizeof(Tcl_Pid));

    curInFile = inputFile;

    for (Tcl_Size i = 0; i < argc; i = lastArg + 1) {
	int result;
	bool joinThisError;
	Tcl_Pid pid;
	const char *oldName;

	/*
	 * Convert the program name into native form.
	 */

	if (Tcl_TranslateFileName(interp, argv[i], &execBuffer) == NULL) {
	    goto error;
	}

	/*
	 * Find the end of the current segment of the pipeline.
	 */

	joinThisError = false;
	for (lastArg = i; lastArg < argc; lastArg++) {
	    if (argv[lastArg][0] != '|') {
		continue;
	    }
	    if (argv[lastArg][1] == '\0') {
		break;
	    }
	    if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
		joinThisError = true;
		break;
	    }
	}

	/*
	 * If this is the last segment, use the specified outputFile.
	 * Otherwise create an intermediate pipe. pipeIn will become the
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	    if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
		TclPrintfResult(interp, "couldn't create pipe: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	}

	if (joinThisError != 0) {
	    curErrFile = curOutFile;
	} else {
	    curErrFile = errorFile;
	}

	/*
	 * Restore argv[i], since a caller wouldn't expect the contents of







|







857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	    if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
		TclPrintfResult(interp, "couldn't create pipe: %s",
			Tcl_PosixError(interp));
		goto error;
	    }
	}

	if (joinThisError) {
	    curErrFile = curOutFile;
	} else {
	    curErrFile = errorFile;
	}

	/*
	 * Restore argv[i], since a caller wouldn't expect the contents of
Changes to generic/tclPkg.c.
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
} RequireProcArgs;

/*
 * Prototypes for functions defined in this file:
 */

static int		CheckVersionAndConvert(Tcl_Interp *interp,
			    const char *string, char **internal, int *stable);
static int		CompareVersions(char *v1i, char *v2i,
			    int *isMajorPtr);
static int		CheckRequirement(Tcl_Interp *interp,
			    const char *string);
static int		CheckAllRequirements(Tcl_Interp *interp, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static int		RequirementSatisfied(char *havei, const char *req);
static int		SomeRequirementSatisfied(char *havei, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToResult(Tcl_Interp *interp, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToDString(Tcl_DString *dstring,
			    int reqc, Tcl_Obj *const reqv[]);
static Package *	FindPackage(Tcl_Interp *interp, const char *name);
static int		PkgRequireCore(void *data[], Tcl_Interp *interp, int result);







|

|




|
|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
} RequireProcArgs;

/*
 * Prototypes for functions defined in this file:
 */

static int		CheckVersionAndConvert(Tcl_Interp *interp,
			    const char *string, char **internal, bool *stable);
static int		CompareVersions(char *v1i, char *v2i,
			    bool *isMajorPtr);
static int		CheckRequirement(Tcl_Interp *interp,
			    const char *string);
static int		CheckAllRequirements(Tcl_Interp *interp, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static bool		RequirementSatisfied(char *havei, const char *req);
static bool		SomeRequirementSatisfied(char *havei, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToResult(Tcl_Interp *interp, Tcl_Size reqc,
			    Tcl_Obj *const reqv[]);
static void		AddRequirementsToDString(Tcl_DString *dstring,
			    int reqc, Tcl_Obj *const reqv[]);
static Package *	FindPackage(Tcl_Interp *interp, const char *name);
static int		PkgRequireCore(void *data[], Tcl_Interp *interp, int result);
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
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of package. */
    const char *version,	/* Version string for package. */
    const void *clientData)	/* clientdata for this package (normally used
				 * for C callback function table) */
{
    Package *pkgPtr;
    char *pvi, *vi;
    int res;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = Tcl_NewStringObj(version, -1);
	Tcl_IncrRefCount(pkgPtr->version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
	    NULL) != TCL_OK) {
	return TCL_ERROR;
    } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
	Tcl_Free(pvi);
	return TCL_ERROR;
    }

    res = CompareVersions(pvi, vi, NULL);
    Tcl_Free(pvi);
    Tcl_Free(vi);

    if (res == 0) {
	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}







<

<

|















|







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
    Tcl_Interp *interp,		/* Interpreter in which package is now
				 * available. */
    const char *name,		/* Name of package. */
    const char *version,	/* Version string for package. */
    const void *clientData)	/* clientdata for this package (normally used
				 * for C callback function table) */
{

    char *pvi, *vi;


    Package *pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
	pkgPtr->version = Tcl_NewStringObj(version, -1);
	Tcl_IncrRefCount(pkgPtr->version);
	pkgPtr->clientData = clientData;
	return TCL_OK;
    }

    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
	    NULL) != TCL_OK) {
	return TCL_ERROR;
    } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
	Tcl_Free(pvi);
	return TCL_ERROR;
    }

    int res = CompareVersions(pvi, vi, NULL);
    Tcl_Free(pvi);
    Tcl_Free(vi);

    if (res == 0) {
	if (clientData != NULL) {
	    pkgPtr->clientData = clientData;
	}
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

static int
SelectPackage(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int))
{
    int availStable, satisfies;
    Require *reqPtr = (Require *)data[0];
    Tcl_Size reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
    const char *name = reqPtr->name;
    Package *pkgPtr = reqPtr->pkgPtr;
    Interp *iPtr = (Interp *) interp;








|







635
636
637
638
639
640
641
642
643
644
645
646
647
648
649

static int
SelectPackage(
    void *data[],
    Tcl_Interp *interp,
    TCL_UNUSED(int))
{
    bool availStable, satisfies;
    Require *reqPtr = (Require *)data[0];
    Tcl_Size reqc = PTR2INT(data[1]);
    Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
    const char *name = reqPtr->name;
    Package *pkgPtr = reqPtr->pkgPtr;
    Interp *iPtr = (Interp *) interp;

1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
    };
    enum pkgOptionsEnum {
	PKG_FILES,  PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,
	PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    } optionIndex;
    Interp *iPtr = (Interp *) interp;
    int exact, satisfies;
    Tcl_Size newobjc;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;







<







1053
1054
1055
1056
1057
1058
1059

1060
1061
1062
1063
1064
1065
1066
    };
    enum pkgOptionsEnum {
	PKG_FILES,  PKG_FORGET,  PKG_IFNEEDED, PKG_NAMES,   PKG_PREFER,
	PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE,  PKG_UNKNOWN, PKG_VCOMPARE,
	PKG_VERSIONS, PKG_VSATISFIES
    } optionIndex;
    Interp *iPtr = (Interp *) interp;

    Tcl_Size newobjc;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    const char *version;
1233
1234
1235
1236
1237
1238
1239

1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_PRESENT: {
	const char *name;


	if (objc < 3) {
	    goto require;
	}
	argv2 = TclGetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    if (objc != 5) {
		goto requireSyntax;
	    }
	    exact = 1;
	    name = TclGetString(objv[3]);
	} else {
	    exact = 0;
	    name = argv2;
	}

	hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
	if (hPtr != NULL) {
	    pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
	    if (pkgPtr->version != NULL) {







>









|


|







1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
		}
	    }
	    Tcl_SetObjResult(interp, resultObj);
	}
	break;
    case PKG_PRESENT: {
	const char *name;
	bool exact;

	if (objc < 3) {
	    goto require;
	}
	argv2 = TclGetString(objv[2]);
	if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
	    if (objc != 5) {
		goto requireSyntax;
	    }
	    exact = true;
	    name = TclGetString(objv[3]);
	} else {
	    exact = false;
	    name = argv2;
	}

	hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
	if (hPtr != NULL) {
	    pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
	    if (pkgPtr->version != NULL) {
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
	if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) {
	    return TCL_ERROR;
	} else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
	    Tcl_Free(argv2i);
	    return TCL_ERROR;
	}

	satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
	Tcl_Free(argv2i);

	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
	break;
    }
    default:
	TCL_UNREACHABLE();







|







1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
	if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) {
	    return TCL_ERROR;
	} else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
	    Tcl_Free(argv2i);
	    return TCL_ERROR;
	}

	bool satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
	Tcl_Free(argv2i);

	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
	break;
    }
    default:
	TCL_UNREACHABLE();
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
static int
CheckVersionAndConvert(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *string,		/* Supposedly a version number, which is
				 * groups of decimal digits separated by
				 * dots. */
    char **internal,		/* Internal normalized representation */
    int *stable)		/* Flag: Version is (un)stable. */
{
    const char *p = string;
    char prevChar;
    int hasunstable = 0;
    /*
     * 4* assuming that each char is a separator (a,b become ' -x ').
     * 4+ to have space for an additional -2 at the end
     */
    char *ibuf = (char *)Tcl_Alloc(4 + 4*strlen(string));
    char *ip = ibuf;








|



|







1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
static int
CheckVersionAndConvert(
    Tcl_Interp *interp,		/* Used for error reporting. */
    const char *string,		/* Supposedly a version number, which is
				 * groups of decimal digits separated by
				 * dots. */
    char **internal,		/* Internal normalized representation */
    bool *stable)		/* Flag: Version is (un)stable. */
{
    const char *p = string;
    char prevChar;
    bool hasunstable = false;
    /*
     * 4* assuming that each char is a separator (a,b become ' -x ').
     * 4+ to have space for an additional -2 at the end
     */
    char *ibuf = (char *)Tcl_Alloc(4 + 4*strlen(string));
    char *ip = ibuf;

1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
		((prevChar=='a' || prevChar=='b' || prevChar=='.')
			&& (*p=='.')) ||
		((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) {
	    goto error;
	}

	if (*p == 'a' || *p == 'b') {
	    hasunstable = 1;
	}

	/*
	 * Translation to the internal rep. Regular version chars are copied
	 * as is. The separators are translated to numerics. The new separator
	 * for all parts is space.
	 */







|







1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
		((prevChar=='a' || prevChar=='b' || prevChar=='.')
			&& (*p=='.')) ||
		((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) {
	    goto error;
	}

	if (*p == 'a' || *p == 'b') {
	    hasunstable = true;
	}

	/*
	 * Translation to the internal rep. Regular version chars are copied
	 * as is. The separators are translated to numerics. The new separator
	 * for all parts is space.
	 */
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759

1760
1761
1762
1763
1764
1765
1766
 *----------------------------------------------------------------------
 */

static int
CompareVersions(
    char *v1, char *v2,		/* Versions strings, of form 2.1.3 (any number
				 * of version numbers). */
    int *isMajorPtr)		/* If non-null, the word pointed to is filled
				 * in with a 0/1 value. 1 means that the
				 * difference occurred in the first element. */
{
    int thisIsMajor, res, flip;

    char *s1, *e1, *s2, *e2, o1, o2;

    /*
     * Each iteration of the following loop processes one number from each
     * string, terminated by a " " (space). If those numbers don't match then
     * the comparison is over; otherwise, we loop back for the next number.
     *







|
|


|
>







1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
 *----------------------------------------------------------------------
 */

static int
CompareVersions(
    char *v1, char *v2,		/* Versions strings, of form 2.1.3 (any number
				 * of version numbers). */
    bool *isMajorPtr)		/* If non-null, the word pointed to is filled
				 * in with a bool value. true means that the
				 * difference occurred in the first element. */
{
    bool thisIsMajor, flip;
    int res;
    char *s1, *e1, *s2, *e2, o1, o2;

    /*
     * Each iteration of the following loop processes one number from each
     * string, terminated by a " " (space). If those numbers don't match then
     * the comparison is over; otherwise, we loop back for the next number.
     *
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
     * much easier to handle, as it is still regular.
     *
     * Rewritten to not compute a numeric value for the extracted version
     * number, but do string comparison. Skip any leading zeros for that to
     * work. This change breaks through the 32bit-limit on version numbers.
     */

    thisIsMajor = 1;
    s1 = v1;
    s2 = v2;

    while (1) {
	/*
	 * Parse one decimal number from the front of each string. Skip
	 * leading zeros. Terminate found number for upcoming string-wise







|







1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
     * much easier to handle, as it is still regular.
     *
     * Rewritten to not compute a numeric value for the extracted version
     * number, but do string comparison. Skip any leading zeros for that to
     * work. This change breaks through the 32bit-limit on version numbers.
     */

    thisIsMajor = true;
    s1 = v1;
    s2 = v2;

    while (1) {
	/*
	 * Parse one decimal number from the front of each string. Skip
	 * leading zeros. Terminate found number for upcoming string-wise
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
	    break;
	}

	if ((*s1 == '-') && (*s2 == '-')) {
	    /* a < b => -a > -b, etc. */
	    s1++;
	    s2++;
	    flip = 1;
	} else {
	    flip = 0;
	}

	/*
	 * The string comparison is needed, so now we determine where the
	 * numbers end.
	 */








|

|







1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
	    break;
	}

	if ((*s1 == '-') && (*s2 == '-')) {
	    /* a < b => -a > -b, etc. */
	    s1++;
	    s2++;
	    flip = true;
	} else {
	    flip = false;
	}

	/*
	 * The string comparison is needed, so now we determine where the
	 * numbers end.
	 */

1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907

	    res = 0;
	    break;
	}
	if (*s2 != 0) {
	    s2++;
	}
	thisIsMajor = 0;
    }

    if (isMajorPtr != NULL) {
	*isMajorPtr = thisIsMajor;
    }

    return res;







|







1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906

	    res = 0;
	    break;
	}
	if (*s2 != 0) {
	    s2++;
	}
	thisIsMajor = false;
    }

    if (isMajorPtr != NULL) {
	*isMajorPtr = thisIsMajor;
    }

    return res;
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153

2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SomeRequirementSatisfied(
    char *availVersionI,	/* Candidate version to check against the
				 * requirements. */
    Tcl_Size reqc,		/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[])	/* 0 means to use the latest version
				 * available. */
{
    for (Tcl_Size i = 0; i < reqc; i++) {
	if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * RequirementSatisfied --
 *
 *	This function checks to see whether a version satisfies a requirement.
 *
 * Results:
 *	If the requirement is satisfied 1 is returned. Otherwise 0 is
 *	returned. The function assumes that all pieces have valid syntax, and
 *	is allowed to make that assumption.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
RequirementSatisfied(
    char *havei,		/* Version string, of candidate package we
				 * have. */
    const char *req)		/* Requirement string the candidate has to
				 * satisfy. */
{
    /*
     * The have candidate is already in internal rep.
     */


    int satisfied, res;
    char *dash = NULL, *buf, *min, *max;

    dash = (char *)strchr(req, '-');
    if (dash == NULL) {
	/*
	 * No dash found, is a simple version, fallback to regular check. The
	 * 'CheckVersionAndConvert' cannot fail. We pad the requirement with
	 * 'a0', i.e '-2' before doing the comparison to properly accept
	 * unstables as well.
	 */

	char *reqi = NULL;
	int thisIsMajor;

	CheckVersionAndConvert(NULL, req, &reqi, NULL);
	strcat(reqi, " -2");
	res = CompareVersions(havei, reqi, &thisIsMajor);
	satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
	Tcl_Free(reqi);
	return satisfied;







|










|


|










|









|










>
|












|







2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
SomeRequirementSatisfied(
    char *availVersionI,	/* Candidate version to check against the
				 * requirements. */
    Tcl_Size reqc,		/* Requirements constraining the desired
				 * version. */
    Tcl_Obj *const reqv[])	/* 0 means to use the latest version
				 * available. */
{
    for (Tcl_Size i = 0; i < reqc; i++) {
	if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) {
	    return true;
	}
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * RequirementSatisfied --
 *
 *	This function checks to see whether a version satisfies a requirement.
 *
 * Results:
 *	If the requirement is satisfied true is returned. Otherwise false is
 *	returned. The function assumes that all pieces have valid syntax, and
 *	is allowed to make that assumption.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
RequirementSatisfied(
    char *havei,		/* Version string, of candidate package we
				 * have. */
    const char *req)		/* Requirement string the candidate has to
				 * satisfy. */
{
    /*
     * The have candidate is already in internal rep.
     */

    int res;
    bool satisfied;
    char *dash = NULL, *buf, *min, *max;

    dash = (char *)strchr(req, '-');
    if (dash == NULL) {
	/*
	 * No dash found, is a simple version, fallback to regular check. The
	 * 'CheckVersionAndConvert' cannot fail. We pad the requirement with
	 * 'a0', i.e '-2' before doing the comparison to properly accept
	 * unstables as well.
	 */

	char *reqi = NULL;
	bool thisIsMajor;

	CheckVersionAndConvert(NULL, req, &reqi, NULL);
	strcat(reqi, " -2");
	res = CompareVersions(havei, reqi, &thisIsMajor);
	satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
	Tcl_Free(reqi);
	return satisfied;
Changes to generic/tclPreserve.c.
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 * number of calls in effect.
 */

typedef struct {
    void *clientData;		/* Address of preserved block. */
    size_t refCount;		/* Number of Tcl_Preserve calls in effect for
				 * block. */
    int mustFree;		/* Non-zero means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed when
				 * refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Function to call to free. */
} Reference;

/*







|







20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 * number of calls in effect.
 */

typedef struct {
    void *clientData;		/* Address of preserved block. */
    size_t refCount;		/* Number of Tcl_Preserve calls in effect for
				 * block. */
    bool mustFree;		/* True means Tcl_EventuallyFree was
				 * called while a Tcl_Preserve call was in
				 * effect, so the structure must be freed when
				 * refCount becomes zero. */
    Tcl_FreeProc *freeProc;	/* Function to call to free. */
} Reference;

/*
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    /*
     * Make a new entry for the new reference.
     */

    refPtr = &refArray[inUse];
    refPtr->clientData = clientData;
    refPtr->refCount = 1;
    refPtr->mustFree = 0;
    refPtr->freeProc = 0;
    inUse += 1;
    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *







|
|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    /*
     * Make a new entry for the new reference.
     */

    refPtr = &refArray[inUse];
    refPtr->clientData = clientData;
    refPtr->refCount = 1;
    refPtr->mustFree = false;
    refPtr->freeProc = NULL;
    inUse += 1;
    Tcl_MutexUnlock(&preserveMutex);
}

/*
 *----------------------------------------------------------------------
 *
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	if (refPtr->mustFree) {
	    Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData);
	}
	refPtr->mustFree = 1;
	refPtr->freeProc = freeProc;
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }
    Tcl_MutexUnlock(&preserveMutex);

    /*







|







275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
    for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
	if (refPtr->clientData != clientData) {
	    continue;
	}
	if (refPtr->mustFree) {
	    Tcl_Panic("Tcl_EventuallyFree called twice for %p", clientData);
	}
	refPtr->mustFree = true;
	refPtr->freeProc = freeProc;
	Tcl_MutexUnlock(&preserveMutex);
	return;
    }
    Tcl_MutexUnlock(&preserveMutex);

    /*
Changes to generic/tclProc.c.
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
{
    Interp *iPtr = (Interp *) interp;

    Proc *procPtr = NULL;
    Tcl_Size numArgs;
    CompiledLocal *localPtr = NULL;
    Tcl_Obj **argArray;
    int precompiled = 0, result;

    const char *errorCode = NULL;

    ProcGetInternalRep(bodyPtr, procPtr);
    if (procPtr != NULL) {
	/*
	 * Because the body is a TclProProcBody, the actual body is already
	 * compiled, and it is not shared with anyone else, so it's OK not to
	 * unshare it (as a matter of fact, it is bad to unshare it, because
	 * there may be no source code).
	 *
	 * We don't create and initialize a Proc structure for the procedure;
	 * rather, we use what is in the body object. We increment the ref
	 * count of the Proc struct since the command (soon to be created)
	 * will be holding a reference to it.
	 */

	procPtr->iPtr = iPtr;
	procPtr->refCount++;
	precompiled = 1;
    } else {
	/*
	 * If the procedure's body object is shared because its string value
	 * is identical to, e.g., the body of another procedure, we must
	 * create a private copy for this procedure to use. Such sharing of
	 * procedure bodies is rare but can cause problems. A procedure body
	 * is compiled in a context that includes the number of "slots"







|
>


















|







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
{
    Interp *iPtr = (Interp *) interp;

    Proc *procPtr = NULL;
    Tcl_Size numArgs;
    CompiledLocal *localPtr = NULL;
    Tcl_Obj **argArray;
    bool precompiled = false;
    int result;
    const char *errorCode = NULL;

    ProcGetInternalRep(bodyPtr, procPtr);
    if (procPtr != NULL) {
	/*
	 * Because the body is a TclProProcBody, the actual body is already
	 * compiled, and it is not shared with anyone else, so it's OK not to
	 * unshare it (as a matter of fact, it is bad to unshare it, because
	 * there may be no source code).
	 *
	 * We don't create and initialize a Proc structure for the procedure;
	 * rather, we use what is in the body object. We increment the ref
	 * count of the Proc struct since the command (soon to be created)
	 * will be holding a reference to it.
	 */

	procPtr->iPtr = iPtr;
	procPtr->refCount++;
	precompiled = true;
    } else {
	/*
	 * If the procedure's body object is shared because its string value
	 * is identical to, e.g., the body of another procedure, we must
	 * create a private copy for this procedure to use. Such sharing of
	 * procedure bodies is rare but can cause problems. A procedure body
	 * is compiled in a context that includes the number of "slots"
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298

1299
1300
1301
1302
1303

1304
1305
1306
1307
1308

1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
    Proc *procPtr)
{
    Interp *iPtr = procPtr->iPtr;
    ByteCode *codePtr;
    Tcl_Size localCt = procPtr->numCompiledLocals;
    Tcl_Size numArgs = procPtr->numArgs, i = 0;

    Tcl_Obj **namePtr;
    Var *varPtr;
    LocalCache *localCachePtr;
    CompiledLocal *localPtr;
    int isNew;

    ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);

    /*
     * Cache the names and initial values of local variables; store the
     * cache in both the framePtr for this execution and in the codePtr
     * for future calls.
     */

    localCachePtr = (LocalCache *)Tcl_Alloc(offsetof(LocalCache, varName0)

	    + localCt * sizeof(Tcl_Obj *)
	    + numArgs * sizeof(Var));

    namePtr = &localCachePtr->varName0;
    varPtr = (Var *) (namePtr + localCt);

    localPtr = procPtr->firstLocalPtr;
    while (localPtr) {
	if (TclIsVarTemporary(localPtr)) {
	    *namePtr = NULL;
	} else {

	    *namePtr = TclCreateLiteral(iPtr, localPtr->name,
		    localPtr->nameLength, /* hash */ TCL_INDEX_NONE,
		    &isNew, /* nsPtr */ NULL, 0, NULL);
	    Tcl_IncrRefCount(*namePtr);
	}

	if (i < numArgs) {
	    varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
	    varPtr->value.objPtr = localPtr->defValuePtr;
	    varPtr++;
	    i++;
	}
	namePtr++;
	localPtr = localPtr->nextPtr;
    }
    codePtr->localCachePtr = localCachePtr;
    localCachePtr->refCount = 1;
    localCachePtr->numVars = localCt;
}

/*







<
<
<
<
<
<








|
>


<
|
|
>
|
|



>













<







1278
1279
1280
1281
1282
1283
1284






1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296

1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318

1319
1320
1321
1322
1323
1324
1325
    Proc *procPtr)
{
    Interp *iPtr = procPtr->iPtr;
    ByteCode *codePtr;
    Tcl_Size localCt = procPtr->numCompiledLocals;
    Tcl_Size numArgs = procPtr->numArgs, i = 0;







    ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);

    /*
     * Cache the names and initial values of local variables; store the
     * cache in both the framePtr for this execution and in the codePtr
     * for future calls.
     */

    LocalCache *localCachePtr = (LocalCache *)Tcl_Alloc(
	    offsetof(LocalCache, varName0)
	    + localCt * sizeof(Tcl_Obj *)
	    + numArgs * sizeof(Var));

    Tcl_Obj **namePtr = &localCachePtr->varName0;
    Var *varPtr = (Var *) (namePtr + localCt);

    for (CompiledLocal *localPtr = procPtr->firstLocalPtr; localPtr;
	    localPtr = localPtr->nextPtr) {
	if (TclIsVarTemporary(localPtr)) {
	    *namePtr = NULL;
	} else {
	    bool isNew;
	    *namePtr = TclCreateLiteral(iPtr, localPtr->name,
		    localPtr->nameLength, /* hash */ TCL_INDEX_NONE,
		    &isNew, /* nsPtr */ NULL, 0, NULL);
	    Tcl_IncrRefCount(*namePtr);
	}

	if (i < numArgs) {
	    varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
	    varPtr->value.objPtr = localPtr->defValuePtr;
	    varPtr++;
	    i++;
	}
	namePtr++;

    }
    codePtr->localCachePtr = localCachePtr;
    localCachePtr->refCount = 1;
    localCachePtr->numVars = localCt;
}

/*
Changes to generic/tclProcess.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#include "tclInt.h"

/*
 * Autopurge flag. Process-global because of the way Tcl manages child
 * processes (see tclPipe.c).
 */

static int autopurge = 1;	/* Autopurge flag. */

/*
 * Hash tables that keeps track of all child process statuses. Keys are the
 * child process ids and resolved pids, values are (ProcessInfo *).
 */

typedef struct ProcessInfo {
    Tcl_Pid pid;		/* Process id. */
    Tcl_Size resolvedPid;	/* Resolved process id. */
    int purge;			/* Purge eventualy. */
    TclProcessWaitStatus status;/* Process status. */
    int code;			/* Error code, exit status or signal
				 * number. */
    Tcl_Obj *msg;		/* Error message. */
    Tcl_Obj *error;		/* Error code. */
} ProcessInfo;

static Tcl_HashTable infoTablePerPid;
static Tcl_HashTable infoTablePerResolvedPid;
static int infoTablesInitialized = 0;	/* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(infoTablesMutex)

/*
 * Prototypes for functions defined later in this file:
 */

static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
			    Tcl_Size resolvedPid);
static void		FreeProcessInfo(ProcessInfo *info);
static int		RefreshProcessInfo(ProcessInfo *info, int options);
static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid,
			    int options, int *codePtr, Tcl_Obj **msgPtr,
			    Tcl_Obj **errorObjPtr);
static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
static Tcl_ObjCmdProc ProcessListObjCmd;
static Tcl_ObjCmdProc ProcessStatusObjCmd;
static Tcl_ObjCmdProc ProcessPurgeObjCmd;







|









|









|









|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#include "tclInt.h"

/*
 * Autopurge flag. Process-global because of the way Tcl manages child
 * processes (see tclPipe.c).
 */

static bool autopurge = true;	/* Autopurge flag. */

/*
 * Hash tables that keeps track of all child process statuses. Keys are the
 * child process ids and resolved pids, values are (ProcessInfo *).
 */

typedef struct ProcessInfo {
    Tcl_Pid pid;		/* Process id. */
    Tcl_Size resolvedPid;	/* Resolved process id. */
    bool purge;			/* Purge eventualy. */
    TclProcessWaitStatus status;/* Process status. */
    int code;			/* Error code, exit status or signal
				 * number. */
    Tcl_Obj *msg;		/* Error message. */
    Tcl_Obj *error;		/* Error code. */
} ProcessInfo;

static Tcl_HashTable infoTablePerPid;
static Tcl_HashTable infoTablePerResolvedPid;
static bool infoTablesInitialized = false;
TCL_DECLARE_MUTEX(infoTablesMutex)

/*
 * Prototypes for functions defined later in this file:
 */

static void		InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
			    Tcl_Size resolvedPid);
static void		FreeProcessInfo(ProcessInfo *info);
static bool		RefreshProcessInfo(ProcessInfo *info, int options);
static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid,
			    int options, int *codePtr, Tcl_Obj **msgPtr,
			    Tcl_Obj **errorObjPtr);
static Tcl_Obj *	BuildProcessStatusObj(ProcessInfo *info);
static Tcl_ObjCmdProc ProcessListObjCmd;
static Tcl_ObjCmdProc ProcessStatusObjCmd;
static Tcl_ObjCmdProc ProcessPurgeObjCmd;
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
 *
 * Side effects:
 *	Memory written.
 *
 *----------------------------------------------------------------------
 */

void
InitProcessInfo(
    ProcessInfo *info,		/* Structure to initialize. */
    Tcl_Pid pid,		/* Process id. */
    Tcl_Size resolvedPid)	/* Resolved process id. */
{
    info->pid = pid;
    info->resolvedPid = resolvedPid;
    info->purge = 0;
    info->status = TCL_PROCESS_UNCHANGED;
    info->code = 0;
    info->msg = NULL;
    info->error = NULL;
}

/*







|







|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
 *
 * Side effects:
 *	Memory written.
 *
 *----------------------------------------------------------------------
 */

static void
InitProcessInfo(
    ProcessInfo *info,		/* Structure to initialize. */
    Tcl_Pid pid,		/* Process id. */
    Tcl_Size resolvedPid)	/* Resolved process id. */
{
    info->pid = pid;
    info->resolvedPid = resolvedPid;
    info->purge = false;
    info->status = TCL_PROCESS_UNCHANGED;
    info->code = 0;
    info->msg = NULL;
    info->error = NULL;
}

/*
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
 *
 * Side effects:
 *	Memory deallocated, Tcl_Obj refcount decreased.
 *
 *----------------------------------------------------------------------
 */

void
FreeProcessInfo(
    ProcessInfo *info)		/* Structure to free. */
{
    /*
     * Free stored Tcl_Objs.
     */








|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
 *
 * Side effects:
 *	Memory deallocated, Tcl_Obj refcount decreased.
 *
 *----------------------------------------------------------------------
 */

static void
FreeProcessInfo(
    ProcessInfo *info)		/* Structure to free. */
{
    /*
     * Free stored Tcl_Objs.
     */

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
 *----------------------------------------------------------------------
 *
 * RefreshProcessInfo --
 *
 *	Refresh process info.
 *
 * Results:
 *	Nonzero if state changed, else zero.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

int
RefreshProcessInfo(
    ProcessInfo *info,		/* Structure to refresh. */
    int options)		/* Options passed to WaitProcessStatus. */
{
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Refresh & store status.







|







|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
 *----------------------------------------------------------------------
 *
 * RefreshProcessInfo --
 *
 *	Refresh process info.
 *
 * Results:
 *	True if state changed, else false.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

static bool
RefreshProcessInfo(
    ProcessInfo *info,		/* Structure to refresh. */
    int options)		/* Options passed to WaitProcessStatus. */
{
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Refresh & store status.
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
	}
	return (info->status != TCL_PROCESS_UNCHANGED);
    } else {
	/*
	 * No change.
	 */

	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WaitProcessStatus --
 *
 *	Wait for process status to change.
 *
 * Results:
 *	TclProcessWaitStatus enum value.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

TclProcessWaitStatus
WaitProcessStatus(
    Tcl_Pid pid,		/* Process id. */
    Tcl_Size resolvedPid,	/* Resolved process id. */
    int options,		/* Options passed to Tcl_WaitPid. */
    int *codePtr,		/* If non-NULL, will receive either:
				 *  - 0 for normal exit.
				 *  - errno in case of error.







|



















|







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
	}
	return (info->status != TCL_PROCESS_UNCHANGED);
    } else {
	/*
	 * No change.
	 */

	return false;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * WaitProcessStatus --
 *
 *	Wait for process status to change.
 *
 * Results:
 *	TclProcessWaitStatus enum value.
 *
 * Side effects:
 *	May call WaitProcessStatus, which can block if WNOHANG option is set.
 *
 *----------------------------------------------------------------------
 */

static TclProcessWaitStatus
WaitProcessStatus(
    Tcl_Pid pid,		/* Process id. */
    Tcl_Size resolvedPid,	/* Resolved process id. */
    int options,		/* Options passed to Tcl_WaitPid. */
    int *codePtr,		/* If non-NULL, will receive either:
				 *  - 0 for normal exit.
				 *  - errno in case of error.
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
 *
 * Side effects:
 *	Tcl_Objs are created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
BuildProcessStatusObj(
    ProcessInfo *info)
{
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Process still running, return empty obj.
	 */







|







374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
 *
 * Side effects:
 *	Tcl_Objs are created.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
BuildProcessStatusObj(
    ProcessInfo *info)
{
    if (info->status == TCL_PROCESS_UNCHANGED) {
	/*
	 * Process still running, return empty obj.
	 */
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
    };

    if (infoTablesInitialized == 0) {
	Tcl_MutexLock(&infoTablesMutex);
	if (infoTablesInitialized == 0) {
	    Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
	    Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
	    infoTablesInitialized = 1;
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    }

    Tcl_Command processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
	    "process", 0);







|







781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
    };

    if (infoTablesInitialized == 0) {
	Tcl_MutexLock(&infoTablesMutex);
	if (infoTablesInitialized == 0) {
	    Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
	    Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
	    infoTablesInitialized = true;
	}
	Tcl_MutexUnlock(&infoTablesMutex);
    }

    Tcl_Command processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
    Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
	    "process", 0);
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
	FreeProcessInfo(info);
    } else {
	/*
	 * Eventually purge. Subsequent calls will return
	 * TCL_PROCESS_UNCHANGED.
	 */

	info->purge = 1;
    }
    Tcl_MutexUnlock(&infoTablesMutex);
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|












970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
	FreeProcessInfo(info);
    } else {
	/*
	 * Eventually purge. Subsequent calls will return
	 * TCL_PROCESS_UNCHANGED.
	 */

	info->purge = true;
    }
    Tcl_MutexUnlock(&infoTablesMutex);
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclRegexp.c.
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 * Thread local storage used to maintain a per-thread cache of compiled
 * regular expressions.
 */

#define NUM_REGEXPS 30

typedef struct ThreadSpecificData_RegularExpressions {
    int initialized;		/* Set to 1 when the module is initialized. */
    char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
				 * expression patterns. NULL means that this
				 * slot isn't used. Malloc-ed. */
    size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in
				 * corresponding entry in patterns. -1 means
				 * entry isn't used. */
    struct TclRegexp *regexps[NUM_REGEXPS];







|







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 * Thread local storage used to maintain a per-thread cache of compiled
 * regular expressions.
 */

#define NUM_REGEXPS 30

typedef struct ThreadSpecificData_RegularExpressions {
    bool initialized;		/* Set true when the module is initialized. */
    char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
				 * expression patterns. NULL means that this
				 * slot isn't used. Malloc-ed. */
    size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in
				 * corresponding entry in patterns. -1 means
				 * entry isn't used. */
    struct TclRegexp *regexps[NUM_REGEXPS];
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    const char *text,		/* Text against which to match re. */
    const char *start)		/* If text is part of a larger string, this
				 * identifies beginning of larger string, so
				 * that "^" won't match. */
{
    int flags, result;
    size_t numChars;
    TclRegexp *regexp = (TclRegexp *) re;
    Tcl_DString ds;
    const Tcl_UniChar *ustr;

    /*
     * If the starting point is offset from the beginning of the buffer, then
     * we need to tell the regexp engine not to match "^".
     */

    if (text > start) {







|
<

<
<







187
188
189
190
191
192
193
194

195


196
197
198
199
200
201
202
				 * returned by previous call to
				 * Tcl_GetRegExpFromObj. */
    const char *text,		/* Text against which to match re. */
    const char *start)		/* If text is part of a larger string, this
				 * identifies beginning of larger string, so
				 * that "^" won't match. */
{
    int flags;

    TclRegexp *regexp = (TclRegexp *) re;



    /*
     * If the starting point is offset from the beginning of the buffer, then
     * we need to tell the regexp engine not to match "^".
     */

    if (text > start) {
215
216
217
218
219
220
221

222
223
224
225
226
227
228
229
230
231
232
    regexp->string = text;
    regexp->objPtr = NULL;

    /*
     * Convert the string to Unicode and perform the match.
     */


    Tcl_DStringInit(&ds);
    ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds);
    numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
    result = RegExpExecUniChar(interp, re, ustr, numChars,
	    TCL_INDEX_NONE /* nmatches */, flags);
    Tcl_DStringFree(&ds);

    return result;
}

/*







>

|
|
|







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
    regexp->string = text;
    regexp->objPtr = NULL;

    /*
     * Convert the string to Unicode and perform the match.
     */

    Tcl_DString ds;
    Tcl_DStringInit(&ds);
    const Tcl_UniChar *ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds);
    size_t numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
    int result = RegExpExecUniChar(interp, re, ustr, numChars,
	    TCL_INDEX_NONE /* nmatches */, flags);
    Tcl_DStringFree(&ds);

    return result;
}

/*
257
258
259
260
261
262
263
264
265
266
267
268
269
270

271
272
273
274
275
276
277
				 * subrange. */
    const char **startPtr,	/* Store address of first character in
				 * (sub-)range here. */
    const char **endPtr)	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    const char *string;

    if (index < 0 || (size_t) index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so == (size_t) -1) {
	*startPtr = *endPtr = NULL;
    } else {

	if (regexpPtr->objPtr) {
	    string = TclGetString(regexpPtr->objPtr);
	} else {
	    string = regexpPtr->string;
	}
	*startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
	*endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);







<






>







255
256
257
258
259
260
261

262
263
264
265
266
267
268
269
270
271
272
273
274
275
				 * subrange. */
    const char **startPtr,	/* Store address of first character in
				 * (sub-)range here. */
    const char **endPtr)	/* Store address of character just after last
				 * in (sub-)range here. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;


    if (index < 0 || (size_t) index > regexpPtr->re.re_nsub) {
	*startPtr = *endPtr = NULL;
    } else if (regexpPtr->matches[index].rm_so == (size_t) -1) {
	*startPtr = *endPtr = NULL;
    } else {
	const char *string;
	if (regexpPtr->objPtr) {
	    string = TclGetString(regexpPtr->objPtr);
	} else {
	    string = regexpPtr->string;
	}
	*startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
	*endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327

328

329
330
331

332
333
334
335
336
337
338
339
340
341
342
343
344
345
    const Tcl_UniChar *wString,	/* String against which to match re. */
    size_t numChars,		/* Length of Tcl_UniChar string. */
    size_t nm,			/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means "don't know". */
    int flags)			/* Regular expression flags. */
{
    int status;
    TclRegexp *regexpPtr = (TclRegexp *) re;
    size_t last = regexpPtr->re.re_nsub + 1;

    if (nm >= last) {
	nm = last;
    }

    status = TclReExec(&regexpPtr->re, wString, numChars,
	    &regexpPtr->details, nm, regexpPtr->matches, flags);

    /*
     * Check for errors.
     */


    if (status != REG_OKAY) {

	if (status == REG_NOMATCH) {
	    return 0;
	}

	if (interp != NULL) {
	    TclRegError(interp, "error while matching regular expression: ",
		    status);
	}
	return -1;
    }
    return 1;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclRegExpRangeUniChar --
 *







<







|






>
|
>
|
|
<
>






<







304
305
306
307
308
309
310

311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329

330
331
332
333
334
335
336

337
338
339
340
341
342
343
    const Tcl_UniChar *wString,	/* String against which to match re. */
    size_t numChars,		/* Length of Tcl_UniChar string. */
    size_t nm,			/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means "don't know". */
    int flags)			/* Regular expression flags. */
{

    TclRegexp *regexpPtr = (TclRegexp *) re;
    size_t last = regexpPtr->re.re_nsub + 1;

    if (nm >= last) {
	nm = last;
    }

    int status = TclReExec(&regexpPtr->re, wString, numChars,
	    &regexpPtr->details, nm, regexpPtr->matches, flags);

    /*
     * Check for errors.
     */

    switch (status) {
    case REG_OKAY:
	return 1;
    case REG_NOMATCH:
	return 0;

    default:
	if (interp != NULL) {
	    TclRegError(interp, "error while matching regular expression: ",
		    status);
	}
	return -1;
    }

}

/*
 *---------------------------------------------------------------------------
 *
 * TclRegExpRangeUniChar --
 *
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
				 * should begin. */
    Tcl_Size nmatches,		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means all of them. */
    int flags)			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;
    Tcl_UniChar *udata;
    Tcl_Size length;
    int reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
	(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)

    /*
     * Take advantage of the equivalent glob pattern, if one exists.
     * This is possible based only on the right mix of incoming flags (0)







<
<







444
445
446
447
448
449
450


451
452
453
454
455
456
457
				 * should begin. */
    Tcl_Size nmatches,		/* How many subexpression matches (counting
				 * the whole match as subexpression 0) are of
				 * interest. -1 means all of them. */
    int flags)			/* Regular expression execution flags. */
{
    TclRegexp *regexpPtr = (TclRegexp *) re;


    int reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
	(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)

    /*
     * Take advantage of the equivalent glob pattern, if one exists.
     * This is possible based only on the right mix of incoming flags (0)
478
479
480
481
482
483
484

485
486
487
488
489
490
491
492
    /*
     * Save the target object so we can extract strings from it later.
     */

    regexpPtr->string = NULL;
    regexpPtr->objPtr = textObj;


    udata = Tcl_GetUnicodeFromObj(textObj, &length);

    if (offset > length) {
	offset = length;
    }
    udata += offset;
    length -= offset;








>
|







474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
    /*
     * Save the target object so we can extract strings from it later.
     */

    regexpPtr->string = NULL;
    regexpPtr->objPtr = textObj;

    Tcl_Size length;
    Tcl_UniChar *udata = Tcl_GetUnicodeFromObj(textObj, &length);

    if (offset > length) {
	offset = length;
    }
    udata += offset;
    length -= offset;

590
591
592
593
594
595
596
597
598
599
600
601
602
603

604
605
606
607
608
609
610
611
				 * the interp regexp cache. */
    Tcl_Obj *objPtr,		/* Object whose string rep contains regular
				 * expression pattern. Internal rep will be
				 * changed to compiled form of this regular
				 * expression. */
    int flags)			/* Regular expression compilation flags. */
{
    Tcl_Size length;
    TclRegexp *regexpPtr;
    const char *pattern;

    RegexpGetInternalRep(objPtr, regexpPtr);

    if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {

	pattern = TclGetStringFromObj(objPtr, &length);

	regexpPtr = CompileRegexp(interp, pattern, length, flags);
	if (regexpPtr == NULL) {
	    return NULL;
	}

	RegexpSetInternalRep(objPtr, regexpPtr);







<

<




>
|







587
588
589
590
591
592
593

594

595
596
597
598
599
600
601
602
603
604
605
606
607
				 * the interp regexp cache. */
    Tcl_Obj *objPtr,		/* Object whose string rep contains regular
				 * expression pattern. Internal rep will be
				 * changed to compiled form of this regular
				 * expression. */
    int flags)			/* Regular expression compilation flags. */
{

    TclRegexp *regexpPtr;


    RegexpGetInternalRep(objPtr, regexpPtr);

    if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
	Tcl_Size length;
	const char *pattern = TclGetStringFromObj(objPtr, &length);

	regexpPtr = CompileRegexp(interp, pattern, length, flags);
	if (regexpPtr == NULL) {
	    return NULL;
	}

	RegexpSetInternalRep(objPtr, regexpPtr);
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730

731
732
733
734
735
736
737
void
TclRegError(
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    const char *msg,		/* Message to prepend to error. */
    int status)			/* Status code to report. */
{
    char buf[100];		/* ample in practice */
    char cbuf[TCL_INTEGER_SPACE];
    size_t n;
    const char *p;

    Tcl_ResetResult(interp);
    n = TclReError(status, buf, sizeof(buf));
    p = (n > sizeof(buf)) ? "..." : "";
    TclPrintfResult(interp, "%s%s%s", msg, buf, p);


    snprintf(cbuf, sizeof(cbuf), "%d", status);
    (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
    TclSetErrorCode(interp, "REGEXP", cbuf, buf);
}

/*
 *----------------------------------------------------------------------







<
<
<


|
|


>







711
712
713
714
715
716
717



718
719
720
721
722
723
724
725
726
727
728
729
730
731
void
TclRegError(
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    const char *msg,		/* Message to prepend to error. */
    int status)			/* Status code to report. */
{
    char buf[100];		/* ample in practice */




    Tcl_ResetResult(interp);
    size_t n = TclReError(status, buf, sizeof(buf));
    const char *p = (n > sizeof(buf)) ? "..." : "";
    TclPrintfResult(interp, "%s%s%s", msg, buf, p);

    char cbuf[TCL_INTEGER_SPACE];
    snprintf(cbuf, sizeof(cbuf), "%d", status);
    (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
    TclSetErrorCode(interp, "REGEXP", cbuf, buf);
}

/*
 *----------------------------------------------------------------------
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928

929
930

931
932
933
934
935
936
937
938
static TclRegexp *
CompileRegexp(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    const char *string,		/* The regexp to compile (UTF-8). */
    size_t length,		/* The length of the string in bytes. */
    int flags)			/* Compilation flags. */
{
    TclRegexp *regexpPtr;
    const Tcl_UniChar *uniString;
    int status, i, exact;
    Tcl_Size numChars;
    Tcl_DString stringBuf;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->initialized) {
	tsdPtr->initialized = 1;
	Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
    }

    /*
     * This routine maintains a second-level regular expression cache in
     * addition to the per-object regexp cache. The per-thread cache is needed
     * to handle the case where for various reasons the object is lost between
     * invocations of the regexp command, but the literal pattern is the same.
     */

    /*
     * Check the per-thread compiled regexp cache. We can only reuse a regexp
     * if it has the same pattern and the same flags.
     */

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	if ((length == tsdPtr->patLengths[i])
		&& (tsdPtr->regexps[i]->flags == flags)
		&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the cache and
	     * shift the other patterns down one position.
	     */

	    if (i != 0) {
		int j;
		char *cachedString;

		cachedString = tsdPtr->patterns[i];
		regexpPtr = tsdPtr->regexps[i];
		for (j = i-1; j >= 0; j--) {
		    tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
		    tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
		    tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
		}
		tsdPtr->patterns[0] = cachedString;
		tsdPtr->patLengths[0] = length;
		tsdPtr->regexps[0] = regexpPtr;
	    }
	    return tsdPtr->regexps[0];
	}
    }

    /*
     * This is a new expression, so compile it and add it to the cache.
     */

    regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp));
    regexpPtr->objPtr = NULL;
    regexpPtr->string = NULL;
    regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE;
    regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE;

    /*
     * Get the up-to-date string representation and map to unicode.
     */


    Tcl_DStringInit(&stringBuf);
    uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);

    numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);

    /*
     * Compile the string and check for errors.
     */

    regexpPtr->flags = flags;
    status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);







<
<
|
<
<



|















|









<
<
<
|
|
|
















|









>

|
>
|







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
880
881
882
883
884
885
886



887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
static TclRegexp *
CompileRegexp(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    const char *string,		/* The regexp to compile (UTF-8). */
    size_t length,		/* The length of the string in bytes. */
    int flags)			/* Compilation flags. */
{


    int status;


    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->initialized) {
	tsdPtr->initialized = true;
	Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
    }

    /*
     * This routine maintains a second-level regular expression cache in
     * addition to the per-object regexp cache. The per-thread cache is needed
     * to handle the case where for various reasons the object is lost between
     * invocations of the regexp command, but the literal pattern is the same.
     */

    /*
     * Check the per-thread compiled regexp cache. We can only reuse a regexp
     * if it has the same pattern and the same flags.
     */

    for (int i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	if ((length == tsdPtr->patLengths[i])
		&& (tsdPtr->regexps[i]->flags == flags)
		&& (strcmp(string, tsdPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the cache and
	     * shift the other patterns down one position.
	     */

	    if (i != 0) {



		char *cachedString = tsdPtr->patterns[i];
		TclRegexp *regexpPtr = tsdPtr->regexps[i];
		for (int j = i-1; j >= 0; j--) {
		    tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
		    tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
		    tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
		}
		tsdPtr->patterns[0] = cachedString;
		tsdPtr->patLengths[0] = length;
		tsdPtr->regexps[0] = regexpPtr;
	    }
	    return tsdPtr->regexps[0];
	}
    }

    /*
     * This is a new expression, so compile it and add it to the cache.
     */

    TclRegexp *regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp));
    regexpPtr->objPtr = NULL;
    regexpPtr->string = NULL;
    regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE;
    regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE;

    /*
     * Get the up-to-date string representation and map to unicode.
     */

    Tcl_DString stringBuf;
    Tcl_DStringInit(&stringBuf);
    const Tcl_UniChar *uniString = Tcl_UtfToUniCharDString(string, length,
	    &stringBuf);
    Tcl_Size numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);

    /*
     * Compile the string and check for errors.
     */

    regexpPtr->flags = flags;
    status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
953
954
955
956
957
958
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
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002

    /*
     * Convert RE to a glob pattern equivalent, if any, and cache it.  If this
     * is not possible, then globObjPtr will be NULL.  This is used by
     * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine).
     */

    if (TclReToGlob(NULL, string, length, &stringBuf, &exact,
	    NULL) == TCL_OK) {
	regexpPtr->globObjPtr = Tcl_DStringToObj(&stringBuf);
	Tcl_IncrRefCount(regexpPtr->globObjPtr);
    } else {
	regexpPtr->globObjPtr = NULL;
    }

    /*
     * Allocate enough space for all of the subexpressions, plus one extra for
     * the entire pattern.
     */

    regexpPtr->matches =
	    (regmatch_t*)Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));

    /*
     * Initialize the refcount to one initially, since it is in the cache.
     */

    regexpPtr->refCount = 1;

    /*
     * Free the last regexp, if necessary, and make room at the head of the
     * list for the new regexp.
     */

    if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
	TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];

	if (oldRegexpPtr->refCount-- <= 1) {
	    FreeRegexp(oldRegexpPtr);
	}
	Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]);
    }
    for (i = NUM_REGEXPS - 2; i >= 0; i--) {
	tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
	tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
	tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
    }
    tsdPtr->patterns[0] = (char *)Tcl_Alloc(length + 1);
    memcpy(tsdPtr->patterns[0], string, length + 1);
    tsdPtr->patLengths[0] = length;







|
<











|
|




















|







942
943
944
945
946
947
948
949

950
951
952
953
954
955
956
957
958
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
985
986
987
988
989
990

    /*
     * Convert RE to a glob pattern equivalent, if any, and cache it.  If this
     * is not possible, then globObjPtr will be NULL.  This is used by
     * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine).
     */

    if (TclReToGlob(NULL, string, length, &stringBuf, NULL, NULL) == TCL_OK) {

	regexpPtr->globObjPtr = Tcl_DStringToObj(&stringBuf);
	Tcl_IncrRefCount(regexpPtr->globObjPtr);
    } else {
	regexpPtr->globObjPtr = NULL;
    }

    /*
     * Allocate enough space for all of the subexpressions, plus one extra for
     * the entire pattern.
     */

    regexpPtr->matches = (regmatch_t*)
	    Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));

    /*
     * Initialize the refcount to one initially, since it is in the cache.
     */

    regexpPtr->refCount = 1;

    /*
     * Free the last regexp, if necessary, and make room at the head of the
     * list for the new regexp.
     */

    if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
	TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];

	if (oldRegexpPtr->refCount-- <= 1) {
	    FreeRegexp(oldRegexpPtr);
	}
	Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]);
    }
    for (int i = NUM_REGEXPS - 2; i >= 0; i--) {
	tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
	tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
	tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
    }
    tsdPtr->patterns[0] = (char *)Tcl_Alloc(length + 1);
    memcpy(tsdPtr->patterns[0], string, length + 1);
    tsdPtr->patLengths[0] = length;
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
1078
1079
1080
1081
1082
1083
1084
1085
 *----------------------------------------------------------------------
 */

static void
FinalizeRegexp(
    TCL_UNUSED(void *))
{
    int i;
    TclRegexp *regexpPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	regexpPtr = tsdPtr->regexps[i];
	if (regexpPtr->refCount-- <= 1) {
	    FreeRegexp(regexpPtr);
	}
	Tcl_Free(tsdPtr->patterns[i]);
	tsdPtr->patterns[i] = NULL;
    }

    /*
     * We may find ourselves reinitialized if another finalization routine
     * invokes regexps.
     */

    tsdPtr->initialized = 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







<
<


|
|












|









1039
1040
1041
1042
1043
1044
1045


1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
 *----------------------------------------------------------------------
 */

static void
FinalizeRegexp(
    TCL_UNUSED(void *))
{


    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (int i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
	TclRegexp *regexpPtr = tsdPtr->regexps[i];
	if (regexpPtr->refCount-- <= 1) {
	    FreeRegexp(regexpPtr);
	}
	Tcl_Free(tsdPtr->patterns[i]);
	tsdPtr->patterns[i] = NULL;
    }

    /*
     * We may find ourselves reinitialized if another finalization routine
     * invokes regexps.
     */

    tsdPtr->initialized = false;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclResolve.c.
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

    for (ResolverScheme *resPtr = iPtr->resolverPtr ; resPtr ;
	    resPtr = resPtr->nextPtr) {
	if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
	    resInfoPtr->varResProc = resPtr->varResProc;
	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
	    return 1;
	}
    }

    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RemoveInterpResolvers --
 *







|



|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

    for (ResolverScheme *resPtr = iPtr->resolverPtr ; resPtr ;
	    resPtr = resPtr->nextPtr) {
	if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
	    resInfoPtr->varResProc = resPtr->varResProc;
	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
	    return true;
	}
    }

    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RemoveInterpResolvers --
 *
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
	    BumpCmdRefEpochs(iPtr->globalNsPtr);
	}

	*prevPtrPtr = resPtr->nextPtr;
	Tcl_Free(resPtr->name);
	Tcl_Free(resPtr);

	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * BumpCmdRefEpochs --
 *







|

|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
	    BumpCmdRefEpochs(iPtr->globalNsPtr);
	}

	*prevPtrPtr = resPtr->nextPtr;
	Tcl_Free(resPtr->name);
	Tcl_Free(resPtr);

	return true;
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * BumpCmdRefEpochs --
 *
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

    resInfoPtr->cmdResProc = nsPtr->cmdResProc;
    resInfoPtr->varResProc = nsPtr->varResProc;
    resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;

    if (nsPtr->cmdResProc != NULL || nsPtr->varResProc != NULL ||
	    nsPtr->compiledVarResProc != NULL) {
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|

|









403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

    resInfoPtr->cmdResProc = nsPtr->cmdResProc;
    resInfoPtr->varResProc = nsPtr->varResProc;
    resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;

    if (nsPtr->cmdResProc != NULL || nsPtr->varResProc != NULL ||
	    nsPtr->compiledVarResProc != NULL) {
	return true;
    }
    return false;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclResult.c.
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
    int returnLevel;		/* corresponding field of the Interp */
    int returnCode;		/* struct. These fields taken together are */
    Tcl_Obj *errorInfo;		/* the "state" of the interp. */
    Tcl_Obj *errorCode;
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
    Tcl_Obj *errorStack;
    int resetErrorStack;
} InterpState;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveInterpState --
 *







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
    int returnLevel;		/* corresponding field of the Interp */
    int returnCode;		/* struct. These fields taken together are */
    Tcl_Obj *errorInfo;		/* the "state" of the interp. */
    Tcl_Obj *errorCode;
    Tcl_Obj *returnOpts;
    Tcl_Obj *objResult;
    Tcl_Obj *errorStack;
    bool resetErrorStack;
} InterpState;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SaveInterpState --
 *
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
	if (iPtr->flags & ERR_LEGACY_COPY) {
	    Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		    iPtr->errorInfo, TCL_GLOBAL_ONLY);
	}
	Tcl_DecrRefCount(iPtr->errorInfo);
	iPtr->errorInfo = NULL;
    }
    iPtr->resetErrorStack = 1;
    iPtr->returnLevel = 1;
    iPtr->returnCode = TCL_OK;
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
	iPtr->returnOpts = NULL;
    }
    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);







|







407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
	if (iPtr->flags & ERR_LEGACY_COPY) {
	    Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
		    iPtr->errorInfo, TCL_GLOBAL_ONLY);
	}
	Tcl_DecrRefCount(iPtr->errorInfo);
	iPtr->errorInfo = NULL;
    }
    iPtr->resetErrorStack = true;
    iPtr->returnLevel = 1;
    iPtr->returnCode = TCL_OK;
    if (iPtr->returnOpts) {
	Tcl_DecrRefCount(iPtr->returnOpts);
	iPtr->returnOpts = NULL;
    }
    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
	     * if someone does [return -errorstack [info errorstack]]
	     */

	    if (TclListObjGetElements(interp, valuePtr, &valueObjc,
		    &valueObjv) == TCL_ERROR) {
		return TCL_ERROR;
	    }
	    iPtr->resetErrorStack = 0;
	    TclListObjLength(interp, iPtr->errorStack, &len);

	    /*
	     * Reset while keeping the list internalrep as much as possible.
	     */

	    Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,







|







744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
	     * if someone does [return -errorstack [info errorstack]]
	     */

	    if (TclListObjGetElements(interp, valuePtr, &valueObjc,
		    &valueObjv) == TCL_ERROR) {
		return TCL_ERROR;
	    }
	    iPtr->resetErrorStack = false;
	    TclListObjLength(interp, iPtr->errorStack, &len);

	    /*
	     * Reset while keeping the list internalrep as much as possible.
	     */

	    Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
Changes to generic/tclScan.c.
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

typedef struct {
    Tcl_UniChar start;
    Tcl_UniChar end;
} Range;

typedef struct {
    int exclude;		/* 1 if this is an exclusion set. */
    int nchars;
    Tcl_UniChar *chars;
    int nranges;
    Range *ranges;
} CharSet;

/*
 * Declarations for functions used only in this file.
 */

static const char *	BuildCharSet(CharSet *cset, const char *format);
static int		CharInSet(CharSet *cset, int ch);
static void		ReleaseCharSet(CharSet *cset);
static int		ValidateFormat(Tcl_Interp *interp, const char *format,
			    int numVars, int *totalVars);

/*
 *----------------------------------------------------------------------
 *







|











|







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

typedef struct {
    Tcl_UniChar start;
    Tcl_UniChar end;
} Range;

typedef struct {
    bool exclude;		/* true if this is an exclusion set. */
    int nchars;
    Tcl_UniChar *chars;
    int nranges;
    Range *ranges;
} CharSet;

/*
 * Declarations for functions used only in this file.
 */

static const char *	BuildCharSet(CharSet *cset, const char *format);
static bool		CharInSet(CharSet *cset, int ch);
static void		ReleaseCharSet(CharSet *cset);
static int		ValidateFormat(Tcl_Interp *interp, const char *format,
			    int numVars, int *totalVars);

/*
 *----------------------------------------------------------------------
 *
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    int offset, nranges;
    const char *end;

    memset(cset, 0, sizeof(CharSet));

    offset = TclUtfToUniChar(format, &ch);
    if (ch == '^') {
	cset->exclude = 1;
	format += offset;
	offset = TclUtfToUniChar(format, &ch);
    }
    end = format + offset;

    /*
     * Find the close bracket so we can overallocate the set.







|







81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
    int offset, nranges;
    const char *end;

    memset(cset, 0, sizeof(CharSet));

    offset = TclUtfToUniChar(format, &ch);
    if (ch == '^') {
	cset->exclude = true;
	format += offset;
	offset = TclUtfToUniChar(format, &ch);
    }
    end = format + offset;

    /*
     * Find the close bracket so we can overallocate the set.
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
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CharInSet(
    CharSet *cset,
    int c)			/* Character to test, passed as int because of
				 * non-ANSI prototypes. */
{
    Tcl_UniChar ch = (Tcl_UniChar) c;
    int i, match = 0;

    for (i = 0; i < cset->nchars; i++) {
	if (cset->chars[i] == ch) {
	    match = 1;
	    break;
	}
    }
    if (!match) {
	for (i = 0; i < cset->nranges; i++) {
	    if ((cset->ranges[i].start <= ch) && (ch <= cset->ranges[i].end)) {
		match = 1;
		break;
	    }
	}
    }
    return (cset->exclude ? !match : match);
}








|






|

|

|




|

|







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
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
CharInSet(
    CharSet *cset,
    int c)			/* Character to test, passed as int because of
				 * non-ANSI prototypes. */
{
    Tcl_UniChar ch = (Tcl_UniChar) c;
    bool match = false;

    for (int i = 0; i < cset->nchars; i++) {
	if (cset->chars[i] == ch) {
	    match = true;
	    break;
	}
    }
    if (!match) {
	for (int i = 0; i < cset->nranges; i++) {
	    if ((cset->ranges[i].start <= ch) && (ch <= cset->ranges[i].end)) {
		match = true;
		break;
	    }
	}
    }
    return (cset->exclude ? !match : match);
}

256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280

281
282
283
284
285
286
287
    Tcl_Interp *interp,		/* Current interpreter. */
    const char *format,		/* The format string. */
    int numVars,		/* The number of variables passed to the scan
				 * command. */
    int *totalSubs)		/* The number of variables that will be
				 * required. */
{
    int gotXpg, gotSequential, flags;
    char *end;
    Tcl_UniChar ch = 0;
    int objIndex, xpgSize, nspace = numVars;
    int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int));
    char buf[5] = "";

    /*
     * Initialize an array that records the number of times a variable is
     * assigned to by the format string. We use this to detect if a variable
     * is multiply assigned or left unassigned.
     */

    for (int i = 0; i < nspace; i++) {
	nassign[i] = 0;
    }

    xpgSize = objIndex = gotXpg = gotSequential = 0;


    while (*format != '\0') {
	format += TclUtfToUniChar(format, &ch);

	flags = 0;

	if (ch != '%') {







|


|













|
>







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
    Tcl_Interp *interp,		/* Current interpreter. */
    const char *format,		/* The format string. */
    int numVars,		/* The number of variables passed to the scan
				 * command. */
    int *totalSubs)		/* The number of variables that will be
				 * required. */
{
    bool gotXpg, gotSequential;
    char *end;
    Tcl_UniChar ch = 0;
    int flags, objIndex, xpgSize, nspace = numVars;
    int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int));
    char buf[5] = "";

    /*
     * Initialize an array that records the number of times a variable is
     * assigned to by the format string. We use this to detect if a variable
     * is multiply assigned or left unassigned.
     */

    for (int i = 0; i < nspace; i++) {
	nassign[i] = 0;
    }

    xpgSize = objIndex = 0;
    gotXpg = gotSequential = false;

    while (*format != '\0') {
	format += TclUtfToUniChar(format, &ch);

	flags = 0;

	if (ch != '%') {
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
	    /* assert(value is >= 0) because of the isdigit() check above */
	    unsigned long long ull = strtoull(format-1, &end, 10);	/* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    format += TclUtfToUniChar(format, &ch);
	    gotXpg = 1;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    /* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */
	    if (ull == 0 || ull >= INT_MAX) {
		goto badIndex;
	    }







|







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
	    /* assert(value is >= 0) because of the isdigit() check above */
	    unsigned long long ull = strtoull(format-1, &end, 10);	/* INTL: "C" locale. */
	    if (*end != '$') {
		goto notXpg;
	    }
	    format = end+1;
	    format += TclUtfToUniChar(format, &ch);
	    gotXpg = true;
	    if (gotSequential) {
		goto mixedXPG;
	    }
	    /* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */
	    if (ull == 0 || ull >= INT_MAX) {
		goto badIndex;
	    }
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
		 */
		xpgSize = (xpgSize > (int)ull) ? xpgSize : (int)ull;
	    }
	    goto xpgCheckDone;
	}

    notXpg:
	gotSequential = 1;
	if (gotXpg) {
	mixedXPG:
	    TclPrintfResult(interp,
		    "cannot mix \"%%\" and \"%%n$\" conversion specifiers");
	    TclSetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES");
	    goto error;
	}







|







332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
		 */
		xpgSize = (xpgSize > (int)ull) ? xpgSize : (int)ull;
	    }
	    goto xpgCheckDone;
	}

    notXpg:
	gotSequential = true;
	if (gotXpg) {
	mixedXPG:
	    TclPrintfResult(interp,
		    "cannot mix \"%%\" and \"%%n$\" conversion specifiers");
	    TclSetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES");
	    goto error;
	}
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, result, code;
    const char *string, *end, *baseString;
    char op = 0;
    int underflow = 0;
    Tcl_Size width;
    Tcl_WideInt wideValue;
    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;

    if (objc < 3) {







|







584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    const char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, result, code;
    const char *string, *end, *baseString;
    char op = 0;
    bool underflow = false;
    Tcl_Size width;
    Tcl_WideInt wideValue;
    Tcl_UniChar ch = 0, sch = 0;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;

    if (objc < 3) {
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
	    }
	    continue;
	}

	if (ch != '%') {
	literal:
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	    string += TclUtfToUniChar(string, &sch);
	    if (ch != sch) {
		goto done;
	    }
	    continue;







|







655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
	    }
	    continue;
	}

	if (ch != '%') {
	literal:
	    if (*string == '\0') {
		underflow = true;
		goto done;
	    }
	    string += TclUtfToUniChar(string, &sch);
	    if (ch != sch) {
		goto done;
	    }
	    continue;
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

	/*
	 * At this point, we will need additional characters from the string
	 * to proceed.
	 */

	if (*string == '\0') {
	    underflow = 1;
	    goto done;
	}

	/*
	 * Skip any leading whitespace at the beginning of a field unless the
	 * format suppresses this behavior.
	 */

	if (!(flags & SCAN_NOSKIP)) {
	    while (*string != '\0') {
		offset = TclUtfToUniChar(string, &sch);
		if (!Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		string += offset;
	    }
	    if (*string == '\0') {
		underflow = 1;
		goto done;
	    }
	}

	/*
	 * Perform the requested scanning operation.
	 */







|

















|







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

	/*
	 * At this point, we will need additional characters from the string
	 * to proceed.
	 */

	if (*string == '\0') {
	    underflow = true;
	    goto done;
	}

	/*
	 * Skip any leading whitespace at the beginning of a field unless the
	 * format suppresses this behavior.
	 */

	if (!(flags & SCAN_NOSKIP)) {
	    while (*string != '\0') {
		offset = TclUtfToUniChar(string, &sch);
		if (!Tcl_UniCharIsSpace(sch)) {
		    break;
		}
		string += offset;
	    }
	    if (*string == '\0') {
		underflow = true;
		goto done;
	    }
	}

	/*
	 * Perform the requested scanning operation.
	 */
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
		width = ~0;
	    }
	    if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
		    &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
		Tcl_DecrRefCount(objPtr);
		if (width < 0) {
		    if (*end == '\0') {
			underflow = 1;
		    }
		} else {
		    if (end == string + width) {
			underflow = 1;
		    }
		}
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);







|



|







927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
		width = ~0;
	    }
	    if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
		    &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
		Tcl_DecrRefCount(objPtr);
		if (width < 0) {
		    if (*end == '\0') {
			underflow = true;
		    }
		} else {
		    if (end == string + width) {
			underflow = true;
		    }
		}
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
		width = ~0;
	    }
	    if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
		    &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
		Tcl_DecrRefCount(objPtr);
		if (width < 0) {
		    if (*end == '\0') {
			underflow = 1;
		    }
		} else {
		    if (end == string + width) {
			underflow = 1;
		    }
		}
		goto done;
	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;
	    } else {







|



|







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
		width = ~0;
	    }
	    if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
		    &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
		Tcl_DecrRefCount(objPtr);
		if (width < 0) {
		    if (*end == '\0') {
			underflow = true;
		    }
		} else {
		    if (end == string + width) {
			underflow = true;
		    }
		}
		goto done;
	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;
	    } else {
Changes to generic/tclStrToD.c.
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
    1.0e+16,
    1.0e+32,
    1.0e+64,
    1.0e+128,
    1.0e+256
};

static int n770_fp;		/* Flag is 1 on Nokia N770 floating point.
				 * Nokia's floating point has the words
				 * reversed: if big-endian is 7654 3210,
				 * and little-endian is       0123 4567,
				 * then Nokia's FP is         4567 0123;
				 * little-endian within the 32-bit words but
				 * big-endian between them. */








|







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
    1.0e+16,
    1.0e+32,
    1.0e+64,
    1.0e+128,
    1.0e+256
};

static bool n770_fp;		/* Flag is true on Nokia N770 floating point.
				 * Nokia's floating point has the words
				 * reversed: if big-endian is 7654 3210,
				 * and little-endian is       0123 4567,
				 * then Nokia's FP is         4567 0123;
				 * little-endian within the 32-bit words but
				 * big-endian between them. */

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
    (Tcl_WideUInt) 3125U*3125U*3125U*3125U*3125U*25U /* 5**27 */
};

/*
 * Static functions defined in this file.
 */

static int		AccumulateDecimalDigit(unsigned, int,
			    Tcl_WideUInt *, mp_int *, int);
static double		MakeHighPrecisionDouble(int signum,
			    mp_int *significand, int nSigDigs, int exponent);
static double		MakeLowPrecisionDouble(int signum,
			    Tcl_WideUInt significand, int nSigDigs,
			    int exponent);
#ifdef IEEE_FLOATING_POINT







|







291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
    (Tcl_WideUInt) 3125U*3125U*3125U*3125U*3125U*25U /* 5**27 */
};

/*
 * Static functions defined in this file.
 */

static bool		AccumulateDecimalDigit(unsigned, int,
			    Tcl_WideUInt *, mp_int *, int);
static double		MakeHighPrecisionDouble(int signum,
			    mp_int *significand, int nSigDigs, int exponent);
static double		MakeLowPrecisionDouble(int signum,
			    Tcl_WideUInt significand, int nSigDigs,
			    int exponent);
#ifdef IEEE_FLOATING_POINT
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
static void		CastOutPowersOf2(int *, int *, int *);
static char *		ShorteningInt64Conversion(Double *, Tcl_WideUInt,
			    int, int, int, int, int, int, int, int, int,
			    int, int, int *, char **);
static char *		StrictInt64Conversion(Tcl_WideUInt,
			    int, int, int, int, int, int,
			    int, int, int *, char **);
static int		ShouldBankerRoundUpPowD(mp_int *, int, int);
static int		ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *,
			    int, int, mp_int *);
static char *		ShorteningBignumConversionPowD(Double *dPtr,
			    Tcl_WideUInt bw, int b2, int b5,
			    int m2plus, int m2minus, int m5,
			    int sd, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static char *		StrictBignumConversionPowD(
			    Tcl_WideUInt bw, int b2, int b5,
			    int sd, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static int		ShouldBankerRoundUp(mp_int *, mp_int *, int);
static int		ShouldBankerRoundUpToNext(mp_int *, mp_int *,
			    mp_int *, int);
static char *		ShorteningBignumConversion(Double *dPtr,
			    Tcl_WideUInt bw, int b2,
			    int m2plus, int m2minus,
			    int s2, int s5, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static char *		StrictBignumConversion(







|
|
|











|
|
|







331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
static void		CastOutPowersOf2(int *, int *, int *);
static char *		ShorteningInt64Conversion(Double *, Tcl_WideUInt,
			    int, int, int, int, int, int, int, int, int,
			    int, int, int *, char **);
static char *		StrictInt64Conversion(Tcl_WideUInt,
			    int, int, int, int, int, int,
			    int, int, int *, char **);
static bool		ShouldBankerRoundUpPowD(mp_int *, int, bool);
static bool		ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *,
			    int, bool, mp_int *);
static char *		ShorteningBignumConversionPowD(Double *dPtr,
			    Tcl_WideUInt bw, int b2, int b5,
			    int m2plus, int m2minus, int m5,
			    int sd, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static char *		StrictBignumConversionPowD(
			    Tcl_WideUInt bw, int b2, int b5,
			    int sd, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static bool		ShouldBankerRoundUp(mp_int *, mp_int *, bool);
static bool		ShouldBankerRoundUpToNext(mp_int *, mp_int *,
			    mp_int *, bool);
static char *		ShorteningBignumConversion(Double *dPtr,
			    Tcl_WideUInt bw, int b2,
			    int m2plus, int m2minus,
			    int s2, int s5, int k, int len,
			    int ilim, int ilim1, int *decpt,
			    char **endPtr);
static char *		StrictBignumConversion(
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527

    int signum = 0;		/* Sign of the number being parsed. */
    Tcl_WideUInt significandWide = 0;
				/* Significand of the number being parsed (if
				 * no overflow). */
    mp_int significandBig;	/* Significand of the number being parsed (if
				 * it overflows significandWide). */
    int significandOverflow = 0;/* Flag==1 iff significandBig is used. */
    Tcl_WideUInt octalSignificandWide = 0;
				/* Significand of an octal number; needed
				 * because we don't know whether a number with
				 * a leading zero is octal or decimal until
				 * we've scanned forward to a '.' or 'e'. */
    mp_int octalSignificandBig;	/* Significand of octal number once
				 * octalSignificandWide overflows. */
    int octalSignificandOverflow = 0;
				/* Flag==1 if octalSignificandBig is used. */
    int numSigDigs = 0;		/* Number of significant digits in the decimal
				 * significand. */
    int numTrailZeros = 0;	/* Number of trailing zeroes at the current
				 * point in the parse. */
    int numDigitsAfterDp = 0;	/* Number of digits scanned after the decimal
				 * point. */
    int exponentSignum = 0;	/* Signum of the exponent of a floating point







|







|
|







504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527

    int signum = 0;		/* Sign of the number being parsed. */
    Tcl_WideUInt significandWide = 0;
				/* Significand of the number being parsed (if
				 * no overflow). */
    mp_int significandBig;	/* Significand of the number being parsed (if
				 * it overflows significandWide). */
    bool significandOverflow = false;/* True iff significandBig is used. */
    Tcl_WideUInt octalSignificandWide = 0;
				/* Significand of an octal number; needed
				 * because we don't know whether a number with
				 * a leading zero is octal or decimal until
				 * we've scanned forward to a '.' or 'e'. */
    mp_int octalSignificandBig;	/* Significand of octal number once
				 * octalSignificandWide overflows. */
    bool octalSignificandOverflow = false;
				/* True if octalSignificandBig is used. */
    int numSigDigs = 0;		/* Number of significant digits in the decimal
				 * significand. */
    int numTrailZeros = 0;	/* Number of trailing zeroes at the current
				 * point in the parse. */
    int numDigitsAfterDp = 0;	/* Number of digits scanned after the decimal
				 * point. */
    int exponentSignum = 0;	/* Signum of the exponent of a floating point
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
			 */

			if ((octalSignificandWide != 0)
				&& (((size_t)shift >=
					CHAR_BIT*sizeof(Tcl_WideUInt))
				|| (octalSignificandWide >
					(UWIDE_MAX >> shift)))) {
			    octalSignificandOverflow = 1;
			    err = mp_init_u64(&octalSignificandBig,
				    octalSignificandWide);
			}
		    }
		    if (!octalSignificandOverflow) {
			/*
			 * When the significand is 0, it is possible for the







|







791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
			 */

			if ((octalSignificandWide != 0)
				&& (((size_t)shift >=
					CHAR_BIT*sizeof(Tcl_WideUInt))
				|| (octalSignificandWide >
					(UWIDE_MAX >> shift)))) {
			    octalSignificandOverflow = true;
			    err = mp_init_u64(&octalSignificandBig,
				    octalSignificandWide);
			}
		    }
		    if (!octalSignificandOverflow) {
			/*
			 * When the significand is 0, it is possible for the
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
		     * value being shifted is undefined behavior. Check
		     * for too large shifts first.
		     */

		    if (significandWide != 0 &&
			    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
			    significandWide > (UWIDE_MAX >> shift))) {
			significandOverflow = 1;
			err = mp_init_u64(&significandBig,
				significandWide);
		    }
		}
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the







|







872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
		     * value being shifted is undefined behavior. Check
		     * for too large shifts first.
		     */

		    if (significandWide != 0 &&
			    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
			    significandWide > (UWIDE_MAX >> shift))) {
			significandOverflow = true;
			err = mp_init_u64(&significandBig,
				significandWide);
		    }
		}
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
		     * value being shifted is undefined behavior. Check
		     * for too large shifts first.
		     */

		    if (significandWide != 0 &&
			    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
			    significandWide > (UWIDE_MAX >> shift))) {
			significandOverflow = 1;
			err = mp_init_u64(&significandBig,
				significandWide);
		    }
		}
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the







|







929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
		     * value being shifted is undefined behavior. Check
		     * for too large shifts first.
		     */

		    if (significandWide != 0 &&
			    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
			    significandWide > (UWIDE_MAX >> shift))) {
			significandOverflow = true;
			err = mp_init_u64(&significandBig,
				significandWide);
		    }
		}
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
	    Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'",
		    acceptState, bytes);
	case BINARY:
	    shift = numTrailZeros;
	    if (!significandOverflow && significandWide != 0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    significandWide > (MOST_BITS + signum) >> shift)) {
		significandOverflow = 1;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	    if (shift) {
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
		     * amount to be shifted to equal or exceed the width







|







1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
	    Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'",
		    acceptState, bytes);
	case BINARY:
	    shift = numTrailZeros;
	    if (!significandOverflow && significandWide != 0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    significandWide > (MOST_BITS + signum) >> shift)) {
		significandOverflow = true;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	    if (shift) {
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
		     * amount to be shifted to equal or exceed the width
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
	     * Returning a hex integer. Final scaling step.
	     */

	    shift = 4 * numTrailZeros;
	    if (!significandOverflow && significandWide !=0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    significandWide > (MOST_BITS + signum) >> shift)) {
		significandOverflow = 1;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	    if (shift) {
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
		     * amount to be shifted to equal or exceed the width







|







1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
	     * Returning a hex integer. Final scaling step.
	     */

	    shift = 4 * numTrailZeros;
	    if (!significandOverflow && significandWide !=0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    significandWide > (MOST_BITS + signum) >> shift)) {
		significandOverflow = true;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	    if (shift) {
		if (!significandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
		     * amount to be shifted to equal or exceed the width
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
	     * Returning an octal integer. Final scaling step.
	     */

	    shift = 3 * numTrailZeros;
	    if (!octalSignificandOverflow && octalSignificandWide != 0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    octalSignificandWide > (MOST_BITS + signum) >> shift)) {
		octalSignificandOverflow = 1;
		err = mp_init_u64(&octalSignificandBig,
			octalSignificandWide);
	    }
	    if (shift) {
		if (!octalSignificandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the







|







1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
	     * Returning an octal integer. Final scaling step.
	     */

	    shift = 3 * numTrailZeros;
	    if (!octalSignificandOverflow && octalSignificandWide != 0 &&
		    ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
		    octalSignificandWide > (MOST_BITS + signum) >> shift)) {
		octalSignificandOverflow = true;
		err = mp_init_u64(&octalSignificandBig,
			octalSignificandWide);
	    }
	    if (shift) {
		if (!octalSignificandOverflow) {
		    /*
		     * When the significand is 0, it is possible for the
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
			    &octalSignificandBig);
		}
	    }
	    if (!octalSignificandOverflow) {
		if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
		    err = mp_init_u64(&octalSignificandBig,
			    octalSignificandWide);
		    octalSignificandOverflow = 1;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.wideValue =
				(Tcl_WideInt)(-octalSignificandWide);
		    } else {
			objPtr->internalRep.wideValue =







|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
			    &octalSignificandBig);
		}
	    }
	    if (!octalSignificandOverflow) {
		if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
		    err = mp_init_u64(&octalSignificandBig,
			    octalSignificandWide);
		    octalSignificandOverflow = true;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.wideValue =
				(Tcl_WideInt)(-octalSignificandWide);
		    } else {
			objPtr->internalRep.wideValue =
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
	    break;

	case ZERO:
	case DECIMAL:
	    significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
		    &significandWide, &significandBig, significandOverflow);
	    if ((err == MP_OKAY) && !significandOverflow && (significandWide > MOST_BITS+signum)) {
		significandOverflow = 1;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	returnInteger:
	    if (!significandOverflow) {
		if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
		    err = mp_init_u64(&significandBig,
			    significandWide);
		    significandOverflow = 1;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.wideValue =
				(Tcl_WideInt)(-significandWide);
		    } else {
			objPtr->internalRep.wideValue =







|







|







1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
	    break;

	case ZERO:
	case DECIMAL:
	    significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
		    &significandWide, &significandBig, significandOverflow);
	    if ((err == MP_OKAY) && !significandOverflow && (significandWide > MOST_BITS+signum)) {
		significandOverflow = true;
		err = mp_init_u64(&significandBig, significandWide);
	    }
	returnInteger:
	    if (!significandOverflow) {
		if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
		    err = mp_init_u64(&significandBig,
			    significandWide);
		    significandOverflow = true;
		} else {
		    objPtr->typePtr = &tclIntType;
		    if (signum) {
			objPtr->internalRep.wideValue =
				(Tcl_WideInt)(-significandWide);
		    } else {
			objPtr->internalRep.wideValue =
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
 *----------------------------------------------------------------------
 *
 * AccumulateDecimalDigit --
 *
 *	Consume a decimal digit in a number being scanned.
 *
 * Results:
 *	Returns 1 if the number has overflowed to a bignum, 0 if it still fits
 *	in a wide integer.
 *
 * Side effects:
 *	Updates either the wide or bignum representation.
 *
 *----------------------------------------------------------------------
 */

static int
AccumulateDecimalDigit(
    unsigned digit,		/* Digit being scanned. */
    int numZeros,		/* Count of zero digits preceding the digit
				 * being scanned. */
    Tcl_WideUInt *wideRepPtr,	/* Representation of the partial number as a
				 * wide integer. */
    mp_int *bignumRepPtr,	/* Representation of the partial number as a







|
|







|







1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
 *----------------------------------------------------------------------
 *
 * AccumulateDecimalDigit --
 *
 *	Consume a decimal digit in a number being scanned.
 *
 * Results:
 *	Returns true if the number has overflowed to a bignum, false if it
 *	still fits in a wide integer.
 *
 * Side effects:
 *	Updates either the wide or bignum representation.
 *
 *----------------------------------------------------------------------
 */

static bool
AccumulateDecimalDigit(
    unsigned digit,		/* Digit being scanned. */
    int numZeros,		/* Count of zero digits preceding the digit
				 * being scanned. */
    Tcl_WideUInt *wideRepPtr,	/* Representation of the partial number as a
				 * wide integer. */
    mp_int *bignumRepPtr,	/* Representation of the partial number as a
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
	Tcl_WideUInt w = *wideRepPtr;
	if (w == 0) {
	    /*
	     * There's no need to multiply if the multiplicand is zero.
	     */

	    *wideRepPtr = digit;
	    return 0;
	} else if (numZeros >= maxpow10_wide
		|| w > (UWIDE_MAX-digit)/pow10_wide[numZeros+1]) {
	    /*
	     * Wide multiplication will overflow.  Expand the number to a
	     * bignum and fall through into the bignum case.
	     */

	    if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
		return 0;
	    }
	} else {
	    /*
	     * Wide multiplication.
	     */

	    *wideRepPtr = w * pow10_wide[numZeros+1] + digit;
	    return 0;
	}
    }

    /*
     * Bignum multiplication.
     */

    if (numZeros < log10_DIGIT_MAX) {
	/*
	 * Up to about 8 zeros - single digit multiplication.
	 */

	if ((mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
		bignumRepPtr) != MP_OKAY)
		|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY))
	return 0;

    } else {
	/*
	 * More than single digit multiplication. Multiply by the appropriate
	 * small powers of 5, and then shift. Large strings of zeroes are
	 * eaten 256 at a time; this is less efficient than it could be, but
	 * seems implausible. We presume that MP_DIGIT_BIT is at least 27. The
	 * first multiplication, by up to 10**7, is done with a one-DIGIT







|








|







|














|
|
>







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
	Tcl_WideUInt w = *wideRepPtr;
	if (w == 0) {
	    /*
	     * There's no need to multiply if the multiplicand is zero.
	     */

	    *wideRepPtr = digit;
	    return false;
	} else if (numZeros >= maxpow10_wide
		|| w > (UWIDE_MAX-digit)/pow10_wide[numZeros+1]) {
	    /*
	     * Wide multiplication will overflow.  Expand the number to a
	     * bignum and fall through into the bignum case.
	     */

	    if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
		return false;
	    }
	} else {
	    /*
	     * Wide multiplication.
	     */

	    *wideRepPtr = w * pow10_wide[numZeros+1] + digit;
	    return false;
	}
    }

    /*
     * Bignum multiplication.
     */

    if (numZeros < log10_DIGIT_MAX) {
	/*
	 * Up to about 8 zeros - single digit multiplication.
	 */

	if ((mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
		bignumRepPtr) != MP_OKAY)
		|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
	    return false;
	}
    } else {
	/*
	 * More than single digit multiplication. Multiply by the appropriate
	 * small powers of 5, and then shift. Large strings of zeroes are
	 * eaten 256 at a time; this is less efficient than it could be, but
	 * seems implausible. We presume that MP_DIGIT_BIT is at least 27. The
	 * first multiplication, by up to 10**7, is done with a one-DIGIT
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
	while ((err == MP_OKAY) && (n >= 256)) {
	    err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
	    n -= 256;
	}
	if ((err != MP_OKAY)
		|| (mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr) != MP_OKAY)
		|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
	    return 0;
	}
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeLowPrecisionDouble --
 *







|



|







1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
	while ((err == MP_OKAY) && (n >= 256)) {
	    err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
	    n -= 256;
	}
	if ((err != MP_OKAY)
		|| (mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr) != MP_OKAY)
		|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
	    return false;
	}
    }

    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeLowPrecisionDouble --
 *
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
    int scale;			/* Scale factor for M. */
    int multiplier;		/* Power of two to scale M. */
    double num, den;		/* Numerator and denominator of the correction
				 * term. */
    double quot;		/* Correction term. */
    double minincr;		/* Lower bound on the absolute value of the
				 * correction term. */
    int roundToEven = 0;	/* Flag == TRUE if we need to invoke
				 * "round to even" functionality */
    double rteSignificand;	/* Significand of the round-to-even result */
    int rteExponent;		/* Exponent of the round-to-even result */
    int shift;			/* Shift count for converting numerator
				 * and denominator of corrector to floating
				 * point */
    Tcl_WideInt rteSigWide;	/* Wide integer version of the significand
				 * for testing evenness */







|
|







2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
    int scale;			/* Scale factor for M. */
    int multiplier;		/* Power of two to scale M. */
    double num, den;		/* Numerator and denominator of the correction
				 * term. */
    double quot;		/* Correction term. */
    double minincr;		/* Lower bound on the absolute value of the
				 * correction term. */
    bool roundToEven = false;	/* True if we need to invoke "round to even"
				 * functionality */
    double rteSignificand;	/* Significand of the round-to-even result */
    int rteExponent;		/* Exponent of the round-to-even result */
    int shift;			/* Shift count for converting numerator
				 * and denominator of corrector to floating
				 * point */
    Tcl_WideInt rteSigWide;	/* Wide integer version of the significand
				 * for testing evenness */
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
	mp_clear(&twoMd);
	mp_clear(&twoMv);
	return approxResult;
    case MP_EQ:
	/*
	 * If the error is exactly 1/2 ULP, we need to round to even.
	 */
	roundToEven = 1;
	break;
    case MP_GT:
	/*
	 * We need to correct the result if the error exceeds 1/2 ULP.
	 */
	break;
    }







|







2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
	mp_clear(&twoMd);
	mp_clear(&twoMv);
	return approxResult;
    case MP_EQ:
	/*
	 * If the error is exactly 1/2 ULP, we need to round to even.
	 */
	roundToEven = true;
	break;
    case MP_GT:
	/*
	 * We need to correct the result if the error exceeds 1/2 ULP.
	 */
	break;
    }
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
 * Results:
 *	Returns 1 iff the fraction is more than 1/2, or if the fraction is
 *	exactly 1/2 and the digit is odd.
 *
 *----------------------------------------------------------------------
 */

static inline int
ShouldBankerRoundUpPowD(
    mp_int *b,			/* Numerator of the fraction. */
    int sd,			/* Denominator is 2**(sd*MP_DIGIT_BIT). */
    int isodd)			/* 1 if the digit is odd, 0 if even. */
{
    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;
    }
    for (int i = sd-2; i >= 0; --i) {
	if (b->dp[i] != 0) {
	    return 1;
	}
    }
    return isodd;
}

/*
 *----------------------------------------------------------------------
 *
 * ShouldBankerRoundUpToNextPowD --
 *
 *	Tests whether bankers' rounding will round down in the "denominator is
 *	a power of 2**MP_DIGIT" case.
 *
 * Results:
 *	Returns 1 if the rounding will be performed - which increases the
 *	digit by one - and 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline int
ShouldBankerRoundUpToNextPowD(
    mp_int *b,			/* Numerator of the fraction. */
    mp_int *m,			/* Numerator of the rounding tolerance. */
    int sd,			/* Common denominator is 2**(sd*MP_DIGIT_BIT). */
    int isodd,			/* 1 if the integer significand is odd. */
    mp_int *temp)		/* Work area for the calculation. */
{
    /*
     * Compare B and S-m - which is the same as comparing B+m and S - which we
     * do by computing b+m and doing a bitwhack compare against
     * 2**(MP_DIGIT_BIT*sd)
     */

    if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) {
	/* Too few digits to be > s */
	return 0;
    }
    if (temp->used > sd+1 || temp->dp[sd] > 1) {
				/* >= 2s */
	return 1;
    }
    for (int i = sd-1; i >= 0; --i) {
				/* Check for ==s */
	if (temp->dp[i] != 0) {	/* > s */
	    return 1;
	}
    }
    return isodd;
}

/*
 *----------------------------------------------------------------------







|



|




|


|



|














|
|




|




|










|



|




|







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
 * Results:
 *	Returns 1 iff the fraction is more than 1/2, or if the fraction is
 *	exactly 1/2 and the digit is odd.
 *
 *----------------------------------------------------------------------
 */

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

    if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
	return false;
    }
    if (b->dp[sd-1] != topbit) {
	return true;
    }
    for (int i = sd-2; i >= 0; --i) {
	if (b->dp[i] != 0) {
	    return true;
	}
    }
    return isodd;
}

/*
 *----------------------------------------------------------------------
 *
 * ShouldBankerRoundUpToNextPowD --
 *
 *	Tests whether bankers' rounding will round down in the "denominator is
 *	a power of 2**MP_DIGIT" case.
 *
 * Results:
 *	Returns true if the rounding will be performed - which increases the
 *	digit by one - and false otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline bool
ShouldBankerRoundUpToNextPowD(
    mp_int *b,			/* Numerator of the fraction. */
    mp_int *m,			/* Numerator of the rounding tolerance. */
    int sd,			/* Common denominator is 2**(sd*MP_DIGIT_BIT). */
    bool isodd,			/* 1 if the integer significand is odd. */
    mp_int *temp)		/* Work area for the calculation. */
{
    /*
     * Compare B and S-m - which is the same as comparing B+m and S - which we
     * do by computing b+m and doing a bitwhack compare against
     * 2**(MP_DIGIT_BIT*sd)
     */

    if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) {
	/* Too few digits to be > s */
	return false;
    }
    if (temp->used > sd+1 || temp->dp[sd] > 1) {
				/* >= 2s */
	return true;
    }
    for (int i = sd-1; i >= 0; --i) {
				/* Check for ==s */
	if (temp->dp[i] != 0) {	/* > s */
	    return true;
	}
    }
    return isodd;
}

/*
 *----------------------------------------------------------------------
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
 *
 * ShouldBankerRoundUp --
 *
 *	Tests whether a digit should be rounded up or down when finishing
 *	bignum-based floating point conversion.
 *
 * Results:
 *	Returns 1 if the number needs to be rounded up, 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline int
ShouldBankerRoundUp(
    mp_int *twor,		/* 2x the remainder from thd division that
				 * produced the last digit. */
    mp_int *S,			/* Denominator. */
    int isodd)			/* Flag == 1 if the last digit is odd. */
{
    int r = mp_cmp_mag(twor, S);

    switch (r) {
    case MP_EQ:
	return isodd;
    case MP_GT:
	return 1;
    default:
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ShouldBankerRoundUpToNext --
 *
 *	Tests whether the remainder is great enough to force rounding to the
 *	next higher digit.
 *
 * Results:
 *	Returns 1 if the number should be rounded up, 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline int
ShouldBankerRoundUpToNext(
    mp_int *b,			/* Remainder from the division that produced
				 * the last digit. */
    mp_int *m,			/* Numerator of the rounding tolerance. */
    mp_int *S,			/* Denominator. */
    int isodd)			/* 1 if the integer significand is odd. */
{
    int r;
    mp_int temp;

    /*
     * Compare b and S-m: this is the same as comparing B+m and S.
     */

    if ((mp_init(&temp) != MP_OKAY) || (mp_add(b, m, &temp) != MP_OKAY)) {
	return 0;
    }
    r = mp_cmp_mag(&temp, S);
    mp_clear(&temp);
    switch (r) {
    case MP_EQ:
	return isodd;
    case MP_GT:
	return 1;
    default:
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ShorteningBignumConversion --







|




|




|







|

|

















|





|









|







|

|







3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
 *
 * ShouldBankerRoundUp --
 *
 *	Tests whether a digit should be rounded up or down when finishing
 *	bignum-based floating point conversion.
 *
 * Results:
 *	Returns true if the number needs to be rounded up, false otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline bool
ShouldBankerRoundUp(
    mp_int *twor,		/* 2x the remainder from thd division that
				 * produced the last digit. */
    mp_int *S,			/* Denominator. */
    bool isodd)			/* Flag == 1 if the last digit is odd. */
{
    int r = mp_cmp_mag(twor, S);

    switch (r) {
    case MP_EQ:
	return isodd;
    case MP_GT:
	return true;
    default:
	return false;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ShouldBankerRoundUpToNext --
 *
 *	Tests whether the remainder is great enough to force rounding to the
 *	next higher digit.
 *
 * Results:
 *	Returns 1 if the number should be rounded up, 0 otherwise.
 *
 *----------------------------------------------------------------------
 */

static inline bool
ShouldBankerRoundUpToNext(
    mp_int *b,			/* Remainder from the division that produced
				 * the last digit. */
    mp_int *m,			/* Numerator of the rounding tolerance. */
    mp_int *S,			/* Denominator. */
    bool isodd)			/* 1 if the integer significand is odd. */
{
    int r;
    mp_int temp;

    /*
     * Compare b and S-m: this is the same as comparing B+m and S.
     */

    if ((mp_init(&temp) != MP_OKAY) || (mp_add(b, m, &temp) != MP_OKAY)) {
	return false;
    }
    r = mp_cmp_mag(&temp, S);
    mp_clear(&temp);
    switch (r) {
    case MP_EQ:
	return isodd;
    case MP_GT:
	return true;
    default:
	return false;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ShorteningBignumConversion --
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
 */

void
TclInitDoubleConversion(void)
{
    Tcl_WideUInt u;
    double d;
#ifdef IEEE_FLOATING_POINT
    union {
	double dv;
	Tcl_WideUInt iv;
    } bitwhack;
#endif
    mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
    union fpc_csr mipsCR;

    mipsCR.fc_word = get_fpc_csr();
    mipsCR.fc_struct.flush = 0;
    set_fpc_csr(mipsCR.fc_word);







<
<
<
<
<
<







4643
4644
4645
4646
4647
4648
4649






4650
4651
4652
4653
4654
4655
4656
 */

void
TclInitDoubleConversion(void)
{
    Tcl_WideUInt u;
    double d;






    mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
    union fpc_csr mipsCR;

    mipsCR.fc_word = get_fpc_csr();
    mipsCR.fc_struct.flush = 0;
    set_fpc_csr(mipsCR.fc_word);
4742
4743
4744
4745
4746
4747
4748




4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
     * 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.
     */

#ifdef IEEE_FLOATING_POINT




    bitwhack.dv = 1.000000238418579;
				/* 3ff0 0000 4000 0000 */
    if ((bitwhack.iv >> 32) == 0x3FF00000) {
	n770_fp = 0;
    } else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) {
	n770_fp = 1;
    } else {
	Tcl_Panic("unknown floating point word order on this machine");
    }
#endif
}

/*







>
>
>
>



|

|







4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
     * 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.
     */

#ifdef IEEE_FLOATING_POINT
    union {
	double dv;
	Tcl_WideUInt iv;
    } bitwhack;
    bitwhack.dv = 1.000000238418579;
				/* 3ff0 0000 4000 0000 */
    if ((bitwhack.iv >> 32) == 0x3FF00000) {
	n770_fp = false;
    } else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) {
	n770_fp = true;
    } else {
	Tcl_Panic("unknown floating point word order on this machine");
    }
#endif
}

/*
5000
5001
5002
5003
5004
5005
5006

5007
5008
5009
5010
5011
5012
5013
5014
	r = -TclFloor(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = HUGE_VAL;
	} else {

	    int exact = 1, shift = mantBits - bits;

	    if (err != MP_OKAY) {
		/* just skip */
	    } else if (shift > 0) {
		err = mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_int d;







>
|







4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
	r = -TclFloor(&b);
    } else {
	int bits = mp_count_bits(a);

	if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
	    r = HUGE_VAL;
	} else {
	    bool exact = true;
	    int shift = mantBits - bits;

	    if (err != MP_OKAY) {
		/* just skip */
	    } else if (shift > 0) {
		err = mp_mul_2d(a, shift, &b);
	    } else if (shift < 0) {
		mp_int d;
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341

5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclNokia770Doubles --
 *
 *	Transpose the two words of a number for Nokia 770 floating point
 *	handling.
 *
 *----------------------------------------------------------------------
 */

int

TclNokia770Doubles(void)
{
    return n770_fp;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|
|




<
>












5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340

5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclNokia770Doubles --
 *
 *	Report whether the two words of a number need to be transposed for
 *	Nokia 770 floating point handling.
 *
 *----------------------------------------------------------------------
 */


bool
TclNokia770Doubles(void)
{
    return n770_fp;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclStringObj.c.
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size length = 0;
	unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length);
	if (index >= length) {
		return -1;
	}

	return bytes[index];
    }

    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode == 0) {
	/*
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}







|












|







540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
     * we don't need to convert to a string to perform the indexing operation.
     */

    if (TclIsPureByteArray(objPtr)) {
	Tcl_Size length = 0;
	unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length);
	if (index >= length) {
	    return -1;
	}

	return bytes[index];
    }

    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (!stringPtr->hasUnicode) {
	/*
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    void *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's Tcl_UniChar length should be stored. If
				 * NULL, no length is stored. */
{
    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode == 0) {
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	if (stringPtr->numChars > INT_MAX) {
	    Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"







|







647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
    void *lengthPtr)		/* If non-NULL, the location where the string
				 * rep's Tcl_UniChar length should be stored. If
				 * NULL, no length is stored. */
{
    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (!stringPtr->hasUnicode) {
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	if (stringPtr->numChars > INT_MAX) {
	    Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
    Tcl_Size *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode == 0) {
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	*lengthPtr = stringPtr->numChars;
    }







|







674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
    Tcl_Size *lengthPtr)	/* If non-NULL, the location where the string
				 * rep's unichar length should be stored. If
				 * NULL, no length is stored. */
{
    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (!stringPtr->hasUnicode) {
	FillUnicodeRep(objPtr);
	stringPtr = GET_STRING(objPtr);
    }

    if (lengthPtr != NULL) {
	*lengthPtr = stringPtr->numChars;
    }
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (stringPtr->hasUnicode == 0) {
	/*
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}







|







746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
    /*
     * OK, need to work with the object as a string.
     */

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (!stringPtr->hasUnicode) {
	/*
	 * If numChars is unknown, compute it.
	 */

	if (stringPtr->numChars == TCL_INDEX_NONE) {
	    TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
	}
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the Unicode data.
	 */

	stringPtr->numChars = TCL_INDEX_NONE;
	stringPtr->hasUnicode = 0;
    } else {
	if (length > stringPtr->maxChars) {
	    stringPtr = stringRealloc(stringPtr, length);
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string
	 */

	stringPtr->numChars = length;
	stringPtr->unicode[length] = 0;
	stringPtr->hasUnicode = 1;

	/*
	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
	 * the string rep.
	 */
    }
}







|













|







953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the Unicode data.
	 */

	stringPtr->numChars = TCL_INDEX_NONE;
	stringPtr->hasUnicode = false;
    } else {
	if (length > stringPtr->maxChars) {
	    stringPtr = stringRealloc(stringPtr, length);
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string
	 */

	stringPtr->numChars = length;
	stringPtr->unicode[length] = 0;
	stringPtr->hasUnicode = true;

	/*
	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
	 * the string rep.
	 */
    }
}
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
				 * currently be shared. */
    Tcl_Size length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    if (length < 0) {
	/* Negative lengths => most likely integer overflow */
	return 0;
    }

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
    }
    if (objPtr->bytes && objPtr->length == length) {
	return 1;
    }

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (objPtr->bytes != NULL) {
	/*







|






|







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
				 * currently be shared. */
    Tcl_Size length)		/* Number of bytes desired for string
				 * representation of object, not including
				 * terminating null byte. */
{
    if (length < 0) {
	/* Negative lengths => most likely integer overflow */
	return false;
    }

    if (Tcl_IsShared(objPtr)) {
	Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
    }
    if (objPtr->bytes && objPtr->length == length) {
	return true;
    }

    SetStringFromAny(NULL, objPtr);
    String *stringPtr = GET_STRING(objPtr);

    if (objPtr->bytes != NULL) {
	/*
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
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
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

	    if (objPtr->bytes == &tclEmptyString) {
		newBytes = (char *)Tcl_AttemptAlloc(length + 1U);
	    } else {
		newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U);
	    }
	    if (newBytes == NULL) {
		return 0;
	    }
	    objPtr->bytes = newBytes;
	    stringPtr->allocated = length;
	}

	objPtr->length = length;
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the Unicode data.
	 */

	stringPtr->numChars = TCL_INDEX_NONE;
	stringPtr->hasUnicode = 0;
    } else {
	/*
	 * Changing length of pure Unicode string.
	 */

	if (length > stringPtr->maxChars) {
	    stringPtr = stringAttemptRealloc(stringPtr, length);
	    if (stringPtr == NULL) {
		return 0;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->numChars = length;
	stringPtr->hasUnicode = 1;

	/*
	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
	 * the string rep.
	 */
    }
    return 1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetUnicodeObj --
 *







|













|








|











|






|







1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
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
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095

	    if (objPtr->bytes == &tclEmptyString) {
		newBytes = (char *)Tcl_AttemptAlloc(length + 1U);
	    } else {
		newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U);
	    }
	    if (newBytes == NULL) {
		return false;
	    }
	    objPtr->bytes = newBytes;
	    stringPtr->allocated = length;
	}

	objPtr->length = length;
	objPtr->bytes[length] = 0;

	/*
	 * Invalidate the Unicode data.
	 */

	stringPtr->numChars = TCL_INDEX_NONE;
	stringPtr->hasUnicode = false;
    } else {
	/*
	 * Changing length of pure Unicode string.
	 */

	if (length > stringPtr->maxChars) {
	    stringPtr = stringAttemptRealloc(stringPtr, length);
	    if (stringPtr == NULL) {
		return false;
	    }
	    SET_STRING(objPtr, stringPtr);
	    stringPtr->maxChars = length;
	}

	/*
	 * Mark the new end of the Unicode string.
	 */

	stringPtr->unicode[length] = 0;
	stringPtr->numChars = length;
	stringPtr->hasUnicode = true;

	/*
	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
	 * the string rep.
	 */
    }
    return true;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_SetUnicodeObj --
 *
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
    SET_STRING(objPtr, stringPtr);
    objPtr->typePtr = &tclStringType;

    stringPtr->maxChars = numChars;
    memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
    stringPtr->unicode[numChars] = 0;
    stringPtr->numChars = numChars;
    stringPtr->hasUnicode = 1;

    TclInvalidateStringRep(objPtr);
    stringPtr->allocated = 0;
}

/*
 *----------------------------------------------------------------------







|







1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
    SET_STRING(objPtr, stringPtr);
    objPtr->typePtr = &tclStringType;

    stringPtr->maxChars = numChars;
    memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
    stringPtr->unicode[numChars] = 0;
    stringPtr->numChars = numChars;
    stringPtr->hasUnicode = true;

    TclInvalidateStringRep(objPtr);
    stringPtr->allocated = 0;
}

/*
 *----------------------------------------------------------------------
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
    }

    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = 0;

    if (bytes) {
	memmove(objPtr->bytes + oldLength, bytes, numBytes);
    }
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}







|







1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
    }

    /*
     * Invalidate the unicode data.
     */

    stringPtr->numChars = -1;
    stringPtr->hasUnicode = false;

    if (bytes) {
	memmove(objPtr->bytes + oldLength, bytes, numBytes);
    }
    objPtr->bytes[newLength] = 0;
    objPtr->length = newLength;
}
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
    Tcl_Interp *interp,
    Tcl_Obj *appendObj,
    const char *format,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    const char *span = format, *msg, *errCode;
    int gotXpg = 0, gotSequential = 0;
    Tcl_Size objIndex = 0, originalLength, limit, numBytes = 0;
    Tcl_UniChar ch = 0;
    static const char *mixedXPG =
	    "cannot mix \"%\" and \"%n$\" conversion specifiers";
    static const char *const badIndex[] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"







|







1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
    Tcl_Interp *interp,
    Tcl_Obj *appendObj,
    const char *format,
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    const char *span = format, *msg, *errCode;
    bool gotXpg = false, gotSequential = false;
    Tcl_Size objIndex = 0, originalLength, limit, numBytes = 0;
    Tcl_UniChar ch = 0;
    static const char *mixedXPG =
	    "cannot mix \"%\" and \"%n$\" conversion specifiers";
    static const char *const badIndex[] = {
	"not enough arguments for all format specifiers",
	"\"%n$\" argument index out of range"
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
    limit = TCL_SIZE_MAX - originalLength;

    /*
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {
	char *end;
	int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
	int gotPrecision, sawFlag, useShort = 0, useBig = 0;
	Tcl_WideInt width, precision;
	int useWide = 0;
	int newXpg, allocSegment = 0;
	Tcl_Size numChars, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;







<
|
|

<
|







1845
1846
1847
1848
1849
1850
1851

1852
1853
1854

1855
1856
1857
1858
1859
1860
1861
1862
    limit = TCL_SIZE_MAX - originalLength;

    /*
     * Format string is NUL-terminated.
     */

    while (*format != '\0') {

	bool gotMinus = false, gotHash = false, gotZero = false, gotSpace = false, gotPlus = false;
	bool useShort = false, useBig = false, useWide = false;
	Tcl_WideInt width, precision;

	bool allocSegment = false;
	Tcl_Size numChars, segmentLimit, segmentNumBytes;
	Tcl_Obj *segment;
	int step = TclUtfToUniChar(format, &ch);

	format += step;
	if (ch != '%') {
	    numBytes += step;
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
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
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965

1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003

2004
2005
2006
2007
2008
2009
2010
2011

2012
2013
2014
2015
2016
2017
2018
2019
2020
	    continue;
	}

	/*
	 * Step 1. XPG3 position specifier
	 */

	newXpg = 0;
	if (isdigit(UCHAR(ch))) {

	    int position = strtoul(format, &end, 10);

	    if (*end == '$') {
		newXpg = 1;
		objIndex = position - 1;
		format = end + 1;
		step = TclUtfToUniChar(format, &ch);
	    }
	}
	if (newXpg) {
	    if (gotSequential) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotXpg = 1;
	} else {
	    if (gotXpg) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotSequential = 1;
	}
	if ((objIndex < 0) || (objIndex >= objc)) {
	    msg = badIndex[gotXpg];
	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
	    goto errorMsg;
	}

	/*
	 * Step 2. Set of flags.
	 */

	sawFlag = 1;
	do {
	    switch (ch) {
	    case '-':
		gotMinus = 1;
		break;
	    case '#':
		gotHash = 1;
		break;
	    case '0':
		gotZero = 1;
		break;
	    case ' ':
		gotSpace = 1;
		break;
	    case '+':
		gotPlus = 1;
		break;
	    default:
		sawFlag = 0;
	    }
	    if (sawFlag) {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} while (sawFlag);

	/*
	 * Step 3. Minimum field width.
	 */

	width = 0;
	if (isdigit(UCHAR(ch))) {
	    /* Note ull will be >= 0 because of isdigit check above */

	    unsigned long long ull;
	    ull = strtoull(format, &end, 10);
	    /* Comparison is >=, not >, to leave room for nul */
	    if (ull >= WIDE_MAX) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    width = (Tcl_WideInt)ull;
	    format = end;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetWideIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
		goto error;
	    }
	    if (width < 0) {
		width = -width;
		gotMinus = 1;
	    }
	    objIndex++;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (width > limit) {
	    msg = overflow;
	    errCode = "OVERFLOW";
	    goto errorMsg;
	}

	/*
	 * Step 4. Precision.
	 */


	gotPrecision = precision = 0;
	if (ch == '.') {
	    gotPrecision = 1;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (isdigit(UCHAR(ch))) {
	    /* Note ull will be >= 0 because of isdigit check above */

	    unsigned long long ull;
	    ull = strtoull(format, &end, 10);
	    /* Comparison is >=, not >, to leave room for nul */
	    if (ull >= WIDE_MAX) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    precision = (Tcl_WideInt)ull;







|

>



|











|






|


|








|



|


|


|


|


|


|














>
|
<




















|















>
|

|





>
|
<







1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
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
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966

1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

2014
2015
2016
2017
2018
2019
2020
	    continue;
	}

	/*
	 * Step 1. XPG3 position specifier
	 */

	bool newXpg = false;
	if (isdigit(UCHAR(ch))) {
	    char *end;
	    int position = strtoul(format, &end, 10);

	    if (*end == '$') {
		newXpg = true;
		objIndex = position - 1;
		format = end + 1;
		step = TclUtfToUniChar(format, &ch);
	    }
	}
	if (newXpg) {
	    if (gotSequential) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotXpg = true;
	} else {
	    if (gotXpg) {
		msg = mixedXPG;
		errCode = "MIXEDSPECTYPES";
		goto errorMsg;
	    }
	    gotSequential = true;
	}
	if ((objIndex < 0) || (objIndex >= objc)) {
	    msg = badIndex[(int) gotXpg];
	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
	    goto errorMsg;
	}

	/*
	 * Step 2. Set of flags.
	 */

	bool sawFlag = true;
	do {
	    switch (ch) {
	    case '-':
		gotMinus = true;
		break;
	    case '#':
		gotHash = true;
		break;
	    case '0':
		gotZero = true;
		break;
	    case ' ':
		gotSpace = true;
		break;
	    case '+':
		gotPlus = true;
		break;
	    default:
		sawFlag = false;
	    }
	    if (sawFlag) {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} while (sawFlag);

	/*
	 * Step 3. Minimum field width.
	 */

	width = 0;
	if (isdigit(UCHAR(ch))) {
	    /* Note ull will be >= 0 because of isdigit check above */
	    char *end;
	    unsigned long long ull = strtoull(format, &end, 10);

	    /* Comparison is >=, not >, to leave room for nul */
	    if (ull >= WIDE_MAX) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    width = (Tcl_WideInt)ull;
	    format = end;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
	    }
	    if (TclGetWideIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
		goto error;
	    }
	    if (width < 0) {
		width = -width;
		gotMinus = true;
	    }
	    objIndex++;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (width > limit) {
	    msg = overflow;
	    errCode = "OVERFLOW";
	    goto errorMsg;
	}

	/*
	 * Step 4. Precision.
	 */

	bool gotPrecision = false;
	precision = 0;
	if (ch == '.') {
	    gotPrecision = true;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	}
	if (isdigit(UCHAR(ch))) {
	    /* Note ull will be >= 0 because of isdigit check above */
	    char *end;
	    unsigned long long ull = strtoull(format, &end, 10);

	    /* Comparison is >=, not >, to leave room for nul */
	    if (ull >= WIDE_MAX) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    precision = (Tcl_WideInt)ull;
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
	}

	/*
	 * Step 5. Length modifier.
	 */

	if (ch == 'h') {
	    useShort = 1;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = 1;
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    } else {
		useWide = 1;
	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
		useWide = 1;
	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} else if ((ch == 'q') || (ch == 'j')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useWide = 1;
	} else if ((ch == 't') || (ch == 'z')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (sizeof(void *) > sizeof(int)) {
		useWide = 1;
	    }
	} else if (ch == 'L') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useBig = 1;
	}

	format += step;
	span = format;

	/*
	 * Step 6. The actual conversion character.







|






|



|





|










|




|




|







2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
	}

	/*
	 * Step 5. Length modifier.
	 */

	if (ch == 'h') {
	    useShort = true;
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == 'l') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (ch == 'l') {
		useBig = true;
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    } else {
		useWide = true;
	    }
	} else if (ch == 'I') {
	    if ((format[1] == '6') && (format[2] == '4')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
		useWide = true;
	    } else if ((format[1] == '3') && (format[2] == '2')) {
		format += (step + 2);
		step = TclUtfToUniChar(format, &ch);
	    } else {
		format += step;
		step = TclUtfToUniChar(format, &ch);
	    }
	} else if ((ch == 'q') || (ch == 'j')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useWide = true;
	} else if ((ch == 't') || (ch == 'z')) {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    if (sizeof(void *) > sizeof(int)) {
		useWide = true;
	    }
	} else if (ch == 'L') {
	    format += step;
	    step = TclUtfToUniChar(format, &ch);
	    useBig = true;
	}

	format += step;
	span = format;

	/*
	 * Step 6. The actual conversion character.
2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
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
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
		    if (precision < 1) {
			TclNewObj(segment);
		    } else {
			segment = Tcl_GetRange(segment, 0, precision - 1);
		    }
		    numChars = precision;
		    Tcl_IncrRefCount(segment);
		    allocSegment = 1;
		}
	    }
	    break;
	case 'c': {
	    char buf[4] = "";
	    int code, length;

	    if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    if ((unsigned)code > 0x10FFFF) {
		code = 0xFFFD;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);
	    Tcl_IncrRefCount(segment);
	    allocSegment = 1;
	    break;
	}

	case 'u':
	case 'd':
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    int l;
	    Tcl_WideInt w;
	    mp_int big;
	    int isNegative = 0;
	    Tcl_Size toAppend;

	    if ((ch == 'p') && (sizeof(void *) > sizeof(int))) {
		useWide = 1;
	    }
	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
		if (cmpResult == MP_EQ) {
		    gotHash = 0;
		}
		if (ch == 'u') {
		    if (isNegative) {
			mp_clear(&big);
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}
	    } else if (useWide) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		}
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) {
		    gotHash = 0;
		}
	    } else if (TclGetIntFromObj(NULL, segment, &l) != TCL_OK) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		} else {
		    l = (int) w;
		}
		if (useShort) {
		    s = (short) l;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) {
			gotHash = 0;
		    }
		} else {
		    isNegative = (l < (int) 0);
		    if (l == (int) 0) {
			gotHash = 0;
		    }
		}
	    } else if (useShort) {
		s = (short) l;
		isNegative = (s < (short) 0);
		if (s == (short) 0) {
		    gotHash = 0;
		}
	    } else {
		isNegative = (l < (int) 0);
		if (l == (int) 0) {
		    gotHash = 0;
		}
	    }

	    TclNewObj(segment);
	    allocSegment = 1;
	    segmentLimit = TCL_SIZE_MAX;
	    Tcl_IncrRefCount(segment);

	    if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
		Tcl_AppendToObj(segment,
			(isNegative ? "-" : gotPlus ? "+" : " "), 1);
		segmentLimit -= 1;







|
















|















|



|









|

















|











|




|






|




|




|







2113
2114
2115
2116
2117
2118
2119
2120
2121
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
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
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
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
		    if (precision < 1) {
			TclNewObj(segment);
		    } else {
			segment = Tcl_GetRange(segment, 0, precision - 1);
		    }
		    numChars = precision;
		    Tcl_IncrRefCount(segment);
		    allocSegment = true;
		}
	    }
	    break;
	case 'c': {
	    char buf[4] = "";
	    int code, length;

	    if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
		goto error;
	    }
	    if ((unsigned)code > 0x10FFFF) {
		code = 0xFFFD;
	    }
	    length = Tcl_UniCharToUtf(code, buf);
	    segment = Tcl_NewStringObj(buf, length);
	    Tcl_IncrRefCount(segment);
	    allocSegment = true;
	    break;
	}

	case 'u':
	case 'd':
	case 'o':
	case 'p':
	case 'x':
	case 'X':
	case 'b': {
	    short s = 0;	/* Silence compiler warning; only defined and
				 * used when useShort is true. */
	    int l;
	    Tcl_WideInt w;
	    mp_int big;
	    bool isNegative = false;
	    Tcl_Size toAppend;

	    if ((ch == 'p') && (sizeof(void *) > sizeof(int))) {
		useWide = true;
	    }
	    if (useBig) {
		int cmpResult;
		if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
		    goto error;
		}
		cmpResult = mp_cmp_d(&big, 0);
		isNegative = (cmpResult == MP_LT);
		if (cmpResult == MP_EQ) {
		    gotHash = false;
		}
		if (ch == 'u') {
		    if (isNegative) {
			mp_clear(&big);
			msg = "unsigned bignum format is invalid";
			errCode = "BADUNSIGNED";
			goto errorMsg;
		    } else {
			ch = 'd';
		    }
		}
	    } else if (useWide) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		}
		isNegative = (w < (Tcl_WideInt) 0);
		if (w == (Tcl_WideInt) 0) {
		    gotHash = false;
		}
	    } else if (TclGetIntFromObj(NULL, segment, &l) != TCL_OK) {
		if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
		    goto error;
		} else {
		    l = (int) w;
		}
		if (useShort) {
		    s = (short) l;
		    isNegative = (s < (short) 0);
		    if (s == (short) 0) {
			gotHash = false;
		    }
		} else {
		    isNegative = (l < (int) 0);
		    if (l == (int) 0) {
			gotHash = false;
		    }
		}
	    } else if (useShort) {
		s = (short) l;
		isNegative = (s < (short) 0);
		if (s == (short) 0) {
		    gotHash = false;
		}
	    } else {
		isNegative = (l < (int) 0);
		if (l == (int) 0) {
		    gotHash = false;
		}
	    }

	    TclNewObj(segment);
	    allocSegment = true;
	    segmentLimit = TCL_SIZE_MAX;
	    Tcl_IncrRefCount(segment);

	    if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
		Tcl_AppendToObj(segment,
			(isNegative ? "-" : gotPlus ? "+" : " "), 1);
		segmentLimit -= 1;
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {







|







2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = false;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = 0;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {







|







2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
		    if (length < precision) {
			segmentLimit -= precision - length;
		    }
		    while (length < precision) {
			Tcl_AppendToObj(segment, "0", 1);
			length++;
		    }
		    gotZero = false;
		}
		if (gotZero) {
		    length += Tcl_GetCharLength(segment);
		    if (length < width) {
			segmentLimit -= width - length;
		    }
		    while (length < width) {
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
	     * Don't pass length modifiers!
	     */

	    *p++ = (char) ch;
	    *p = '\0';

	    TclNewObj(segment);
	    allocSegment = 1;
	    if (!Tcl_AttemptSetObjLength(segment, length)) {
		if (allocSegment) {
		    Tcl_DecrRefCount(segment);
		}
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;







|







2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
	     * Don't pass length modifiers!
	     */

	    *p++ = (char) ch;
	    *p = '\0';

	    TclNewObj(segment);
	    allocSegment = true;
	    if (!Tcl_AttemptSetObjLength(segment, length)) {
		if (allocSegment) {
		    Tcl_DecrRefCount(segment);
		}
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
2684
2685
2686
2687
2688
2689
2690
2691

2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
    Tcl_Obj **objv, *list;
    const char *p;

    TclNewObj(list);
    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0, seekingConversion = 1, gotPrecision = 0;

	int lastNum = -1;

	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {
	    case '\0':
		seekingConversion = 0;
		break;
	    case 's': {
		const char *q, *end, *bytes = va_arg(argList, char *);
		seekingConversion = 0;

		/*
		 * The buffer to copy characters from starts at bytes and ends
		 * at either the first NUL byte, or after lastNum bytes, when
		 * caller has indicated a limit.
		 */








|
>












|



|







2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
    Tcl_Obj **objv, *list;
    const char *p;

    TclNewObj(list);
    p = format;
    Tcl_IncrRefCount(list);
    while (*p != '\0') {
	int size = 0;
	bool seekingConversion = true, gotPrecision = false;
	int lastNum = -1;

	if (*p++ != '%') {
	    continue;
	}
	if (*p == '%') {
	    p++;
	    continue;
	}
	do {
	    switch (*p) {
	    case '\0':
		seekingConversion = false;
		break;
	    case 's': {
		const char *q, *end, *bytes = va_arg(argList, char *);
		seekingConversion = false;

		/*
		 * The buffer to copy characters from starts at bytes and ends
		 * at either the first NUL byte, or after lastNum bytes, when
		 * caller has indicated a limit.
		 */

2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
		seekingConversion = 0;
		switch (size) {
		case -1:
		case 0:
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(
			    va_arg(argList, int)));
		    break;
		case 1:







|







2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
	    case 'c':
	    case 'i':
	    case 'u':
	    case 'd':
	    case 'o':
	    case 'x':
	    case 'X':
		seekingConversion = false;
		switch (size) {
		case -1:
		case 0:
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(
			    va_arg(argList, int)));
		    break;
		case 1:
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
		if (size > 0) {
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			    (double)va_arg(argList, long double)));
		} else {
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			    va_arg(argList, double)));
		}
		seekingConversion = 0;
		break;
	    case '*':
		lastNum = va_arg(argList, int);
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
		p++;
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9': {
		char *end;

		lastNum = strtoul(p, &end, 10);
		p = end;
		break;
	    }
	    case '.':
		gotPrecision = 1;
		p++;
		break;
	    case 'l':
		++size;
		p++;
		break;
	    case 't':







|















|







2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
		if (size > 0) {
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			    (double)va_arg(argList, long double)));
		} else {
		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
			    va_arg(argList, double)));
		}
		seekingConversion = false;
		break;
	    case '*':
		lastNum = va_arg(argList, int);
		Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
		p++;
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9': {
		char *end;

		lastNum = strtoul(p, &end, 10);
		p = end;
		break;
	    }
	    case '.':
		gotPrecision = true;
		p++;
		break;
	    case 'l':
		++size;
		p++;
		break;
	    case 't':
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
TclStringCat(
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj * const objv[],
    int flags)
{
    Tcl_Obj *objResultPtr, * const *ov;
    int binary = 1;
    Tcl_Size oc, length = 0;
    int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
    Tcl_Size first = objc - 1;	/* Index of first value possibly not empty */
    Tcl_Size last = 0;		/* Index of last value possibly not empty */
    int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv);

    if (objc <= 1) {
	if (objc != 1) {
	    /* Negative (shouldn't be) no objects; return empty */







|

|







3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
TclStringCat(
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj * const objv[],
    int flags)
{
    Tcl_Obj *objResultPtr, * const *ov;
    bool binary = true;
    Tcl_Size oc, length = 0;
    bool allowUniChar = true, requestUniChar = false, forceUniChar = false;
    Tcl_Size first = objc - 1;	/* Index of first value possibly not empty */
    Tcl_Size last = 0;		/* Index of last value possibly not empty */
    int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv);

    if (objc <= 1) {
	if (objc != 1) {
	    /* Negative (shouldn't be) no objects; return empty */
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
     */

    ov = objv, oc = objc;
    do {
	Tcl_Obj *objPtr = *ov++;

	if (TclIsPureByteArray(objPtr)) {
	    allowUniChar = 0;
	} else if (objPtr->bytes) {
	    /* Value has a string rep. */
	    if (objPtr->length) {
		/*
		 * Non-empty string rep. Not a pure byte-array, so we won't
		 * create a pure byte-array.
		 */

		binary = 0;
		if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
		    forceUniChar = 1;
		} else if ((objPtr->typePtr) && !TclHasInternalRep(objPtr, &tclStringType)) {
		    /* Prevent shimmer of non-string types. */
		    allowUniChar = 0;
		}
	    }
	} else {
	    binary = 0;
	    if (TclHasInternalRep(objPtr, &tclStringType)) {
		/* Have a pure Unicode value; ask to preserve it */
		requestUniChar = 1;
	    } else {
		/* Have another type; prevent shimmer */
		allowUniChar = 0;
	    }
	}
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it







|








|

|


|



|


|


|







3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
     */

    ov = objv, oc = objc;
    do {
	Tcl_Obj *objPtr = *ov++;

	if (TclIsPureByteArray(objPtr)) {
	    allowUniChar = false;
	} else if (objPtr->bytes) {
	    /* Value has a string rep. */
	    if (objPtr->length) {
		/*
		 * Non-empty string rep. Not a pure byte-array, so we won't
		 * create a pure byte-array.
		 */

		binary = false;
		if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
		    forceUniChar = true;
		} else if ((objPtr->typePtr) && !TclHasInternalRep(objPtr, &tclStringType)) {
		    /* Prevent shimmer of non-string types. */
		    allowUniChar = false;
		}
	    }
	} else {
	    binary = false;
	    if (TclHasInternalRep(objPtr, &tclStringType)) {
		/* Have a pure Unicode value; ask to preserve it */
		requestUniChar = true;
	    } else {
		/* Have another type; prevent shimmer */
		allowUniChar = false;
	    }
	}
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318

    Tcl_Size needed = numOrigChars + numAppendChars;
    if (needed > stringPtr->maxChars) {
	GrowUnicodeBuffer(objPtr, needed);
	stringPtr = GET_STRING(objPtr);
    }

    stringPtr->hasUnicode = 1;
    if (bytes) {
	stringPtr->numChars = needed;
    } else {
	numAppendChars = 0;
    }

    Tcl_UniChar *dst = stringPtr->unicode + numOrigChars;







|







4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319

    Tcl_Size needed = numOrigChars + numAppendChars;
    if (needed > stringPtr->maxChars) {
	GrowUnicodeBuffer(objPtr, needed);
	stringPtr = GET_STRING(objPtr);
    }

    stringPtr->hasUnicode = true;
    if (bytes) {
	stringPtr->numChars = needed;
    } else {
	numAppendChars = 0;
    }

    Tcl_UniChar *dst = stringPtr->unicode + numOrigChars;
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
	 * Create a basic String internalrep that just points to the UTF-8 string
	 * already in place at objPtr->bytes.
	 */

	stringPtr->numChars = -1;
	stringPtr->allocated = objPtr->length;
	stringPtr->maxChars = 0;
	stringPtr->hasUnicode = 0;
	SET_STRING(objPtr, stringPtr);
	objPtr->typePtr = &tclStringType;
    }
    return TCL_OK;
}

/*







|







4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
	 * Create a basic String internalrep that just points to the UTF-8 string
	 * already in place at objPtr->bytes.
	 */

	stringPtr->numChars = -1;
	stringPtr->allocated = objPtr->length;
	stringPtr->maxChars = 0;
	stringPtr->hasUnicode = false;
	SET_STRING(objPtr, stringPtr);
	objPtr->typePtr = &tclStringType;
    }
    return TCL_OK;
}

/*
Changes to generic/tclStringRep.h.
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
				 * the number of chars. */
    Tcl_Size allocated;		/* The amount of space allocated for
				 * the UTF-8 string. Does not include nul
				 * terminator so actual allocation is
				 * (allocated+1). */
    Tcl_Size maxChars;		/* Max number of chars that can fit in the
				 * space allocated for the Unicode array. */
    int hasUnicode;		/* Boolean determining whether the string has
				 * a Tcl_UniChar representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Tcl_UniChar units.
				 * The actual size of this field depends on
				 * the maxChars field above. */
} String;

/* Limit on string lengths. The -1 because limit does not include the nul */







|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
				 * the number of chars. */
    Tcl_Size allocated;		/* The amount of space allocated for
				 * the UTF-8 string. Does not include nul
				 * terminator so actual allocation is
				 * (allocated+1). */
    Tcl_Size maxChars;		/* Max number of chars that can fit in the
				 * space allocated for the Unicode array. */
    bool hasUnicode;		/* Boolean determining whether the string has
				 * a Tcl_UniChar representation. */
    Tcl_UniChar unicode[TCLFLEXARRAY];	/* The array of Tcl_UniChar units.
				 * The actual size of this field depends on
				 * the maxChars field above. */
} String;

/* Limit on string lengths. The -1 because limit does not include the nul */
Changes to generic/tclTest.c.
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    char *fromUtfCmd;
} TclEncoding;

/*
 * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
 */

static int exitMainLoop = 0;

/*
 * Event structure used in testing the event queue management procedures.
 */

typedef struct {
    Tcl_Event header;		/* Header common to all events */







|







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    char *fromUtfCmd;
} TclEncoding;

/*
 * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
 */

static bool exitMainLoop = false;

/*
 * Event structure used in testing the event queue management procedures.
 */

typedef struct {
    Tcl_Event header;		/* Header common to all events */
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
static int
TestsetmainloopCmd(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    exitMainLoop = 0;
    Tcl_SetMainLoop(MainLoop);
    return TCL_OK;
}

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







|







6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
static int
TestsetmainloopCmd(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    exitMainLoop = false;
    Tcl_SetMainLoop(MainLoop);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
static int
TestexitmainloopCmd(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    exitMainLoop = 1;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestChannelCmd --







|







6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
static int
TestexitmainloopCmd(
    TCL_UNUSED(void *),
    TCL_UNUSED(Tcl_Interp *),
    TCL_UNUSED(int) /*objc*/,
    TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
    exitMainLoop = true;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestChannelCmd --
Changes to generic/tclTestObj.c.
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

#include <assert.h>

/*
 * Forward declarations for functions defined later in this file:
 */

static int		CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, Tcl_Size varIndex);
static int		GetVariableIndex(Tcl_Interp *interp,
			    Tcl_Obj *obj, Tcl_Size *indexPtr);
static void		SetVarToObj(Tcl_Obj **varPtr, Tcl_Size varIndex, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc	TestbignumobjCmd;
static Tcl_ObjCmdProc	TestbooleanobjCmd;
static Tcl_ObjCmdProc	TestdoubleobjCmd;
static Tcl_ObjCmdProc	TestindexobjCmd;







|







29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

#include <assert.h>

/*
 * Forward declarations for functions defined later in this file:
 */

static bool		CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, Tcl_Size varIndex);
static int		GetVariableIndex(Tcl_Interp *interp,
			    Tcl_Obj *obj, Tcl_Size *indexPtr);
static void		SetVarToObj(Tcl_Obj **varPtr, Tcl_Size varIndex, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc	TestbignumobjCmd;
static Tcl_ObjCmdProc	TestbooleanobjCmd;
static Tcl_ObjCmdProc	TestdoubleobjCmd;
static Tcl_ObjCmdProc	TestindexobjCmd;
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
 *
 * CheckIfVarUnset --
 *
 *	Utility function that checks whether a test variable is readable:
 *	i.e., that varPtr[varIndex] is non-NULL.
 *
 * Results:
 *	1 if the test variable is unset (NULL); 0 otherwise.
 *
 * Side effects:
 *	Sets the interpreter result to an error message if the variable is
 *	unset (NULL).
 *
 *----------------------------------------------------------------------
 */

static int
CheckIfVarUnset(
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Tcl_Obj ** varPtr,
    Tcl_Size varIndex)		/* Index of the test variable to check. */
{
    if (varIndex < 0 || varPtr[varIndex] == NULL) {
	Tcl_ResetResult(interp);
	TclPrintfResult(interp, "variable %" TCL_SIZE_MODIFIER "d is unset (NULL)",
		varIndex);
	return 1;
    }
    return 0;
}

static int
TestisemptyCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */







|








|









|

|







1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
 *
 * CheckIfVarUnset --
 *
 *	Utility function that checks whether a test variable is readable:
 *	i.e., that varPtr[varIndex] is non-NULL.
 *
 * Results:
 *	true if the test variable is unset (NULL); false otherwise.
 *
 * Side effects:
 *	Sets the interpreter result to an error message if the variable is
 *	unset (NULL).
 *
 *----------------------------------------------------------------------
 */

static bool
CheckIfVarUnset(
    Tcl_Interp *interp,		/* Interpreter for error reporting. */
    Tcl_Obj ** varPtr,
    Tcl_Size varIndex)		/* Index of the test variable to check. */
{
    if (varIndex < 0 || varPtr[varIndex] == NULL) {
	Tcl_ResetResult(interp);
	TclPrintfResult(interp, "variable %" TCL_SIZE_MODIFIER "d is unset (NULL)",
		varIndex);
	return true;
    }
    return false;
}

static int
TestisemptyCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
Changes to generic/tclThreadAlloc.c.
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
 * Static functions defined in this file.
 */

static Cache *	GetCache(void);
static void	LockBucket(Cache *cachePtr, int bucket);
static void	UnlockBucket(Cache *cachePtr, int bucket);
static void	PutBlocks(Cache *cachePtr, int bucket, size_t numMove);
static int	GetBlocks(Cache *cachePtr, int bucket);
static Block *	Ptr2Block(void *ptr);
static void *	Block2Ptr(Block *blockPtr, int bucket, size_t reqSize);
static void	MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove);
static void	PutObjs(Cache *fromPtr, size_t numMove);

/*
 * Local variables defined in this file and initialized at startup.







|







128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
 * Static functions defined in this file.
 */

static Cache *	GetCache(void);
static void	LockBucket(Cache *cachePtr, int bucket);
static void	UnlockBucket(Cache *cachePtr, int bucket);
static void	PutBlocks(Cache *cachePtr, int bucket, size_t numMove);
static bool	GetBlocks(Cache *cachePtr, int bucket);
static Block *	Ptr2Block(void *ptr);
static void *	Block2Ptr(Block *blockPtr, int bucket, size_t reqSize);
static void	MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove);
static void	PutObjs(Cache *fromPtr, size_t numMove);

/*
 * Local variables defined in this file and initialized at startup.
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
 *----------------------------------------------------------------------
 *
 * GetBlocks --
 *
 *	Get more blocks for a bucket.
 *
 * Results:
 *	1 if blocks where allocated, 0 otherwise.
 *
 * Side effects:
 *	Cache may be filled with available blocks.
 *
 *----------------------------------------------------------------------
 */

static int
GetBlocks(
    Cache *cachePtr,
    int bucket)
{
    /*
     * First, attempt to move blocks from the shared cache. Note the
     * potentially dirty read of numFree before acquiring the lock which is a







|







|







892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
 *----------------------------------------------------------------------
 *
 * GetBlocks --
 *
 *	Get more blocks for a bucket.
 *
 * Results:
 *	true if blocks where allocated, false otherwise.
 *
 * Side effects:
 *	Cache may be filled with available blocks.
 *
 *----------------------------------------------------------------------
 */

static bool
GetBlocks(
    Cache *cachePtr,
    int bucket)
{
    /*
     * First, attempt to move blocks from the shared cache. Note the
     * potentially dirty read of numFree before acquiring the lock which is a
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
	 * Otherwise, allocate a big new block directly.
	 */

	if (blockPtr == NULL) {
	    size = MAXALLOC;
	    blockPtr = (Block*)TclpSysAlloc(size);
	    if (blockPtr == NULL) {
		return 0;
	    }
	}

	/*
	 * Split the larger block into smaller blocks for this bucket.
	 */

	n = size / bucketInfo[bucket].blockSize;
	cachePtr->buckets[bucket].numFree = n;
	cachePtr->buckets[bucket].firstPtr = blockPtr;
	while (n-- > 1) {
	    blockPtr->nextBlock = (Block *)
		((char *) blockPtr + bucketInfo[bucket].blockSize);
	    blockPtr = blockPtr->nextBlock;
	}
	cachePtr->buckets[bucket].lastPtr = blockPtr;
	blockPtr->nextBlock = NULL;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitThreadAlloc --
 *







|


















|







973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
	 * Otherwise, allocate a big new block directly.
	 */

	if (blockPtr == NULL) {
	    size = MAXALLOC;
	    blockPtr = (Block*)TclpSysAlloc(size);
	    if (blockPtr == NULL) {
		return false;
	    }
	}

	/*
	 * Split the larger block into smaller blocks for this bucket.
	 */

	n = size / bucketInfo[bucket].blockSize;
	cachePtr->buckets[bucket].numFree = n;
	cachePtr->buckets[bucket].firstPtr = blockPtr;
	while (n-- > 1) {
	    blockPtr->nextBlock = (Block *)
		((char *) blockPtr + bucketInfo[bucket].blockSize);
	    blockPtr = blockPtr->nextBlock;
	}
	cachePtr->buckets[bucket].lastPtr = blockPtr;
	blockPtr->nextBlock = NULL;
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitThreadAlloc --
 *
Changes to generic/tclThreadJoin.c.
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 * defined below.
 */

typedef struct JoinableThread {
    Tcl_ThreadId  id;		/* The id of the joinable thread. */
    int result;			/* A place for the result after the demise of
				 * the thread. */
    int done;			/* Boolean flag. Initialized to 0 and set to 1
				 * after the exit of the thread. This allows a
				 * thread requesting a join to detect when
				 * waiting is not necessary. */
    int waitedUpon;		/* Boolean flag. Initialized to 0 and set to 1
				 * by the thread waiting for this one via
				 * Tcl_JoinThread.  Used to lock any other
				 * thread trying to wait on this one. */
    Tcl_Mutex threadMutex;	/* The mutex used to serialize access to this
				 * structure. */
    Tcl_Condition cond;		/* This is the condition a thread has to wait
				 * upon to get notified of the end of the







|



|







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 * defined below.
 */

typedef struct JoinableThread {
    Tcl_ThreadId  id;		/* The id of the joinable thread. */
    int result;			/* A place for the result after the demise of
				 * the thread. */
    bool done;			/* Initialized to false and set to true
				 * after the exit of the thread. This allows a
				 * thread requesting a join to detect when
				 * waiting is not necessary. */
    bool waitedUpon;		/* Initialized to false and set to true
				 * by the thread waiting for this one via
				 * Tcl_JoinThread.  Used to lock any other
				 * thread trying to wait on this one. */
    Tcl_Mutex threadMutex;	/* The mutex used to serialize access to this
				 * structure. */
    Tcl_Condition cond;		/* This is the condition a thread has to wait
				 * upon to get notified of the end of the
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	return TCL_ERROR;
    }

    /*
     * We are waiting now, let other threads recognize this.
     */

    threadPtr->waitedUpon = 1;

    while (!threadPtr->done) {
	Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL);
    }

    /*
     * We have to release the structure before trying to access the list again







|







138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
	return TCL_ERROR;
    }

    /*
     * We are waiting now, let other threads recognize this.
     */

    threadPtr->waitedUpon = true;

    while (!threadPtr->done) {
	Tcl_ConditionWait(&threadPtr->cond, &threadPtr->threadMutex, NULL);
    }

    /*
     * We have to release the structure before trying to access the list again
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
TclRememberJoinableThread(
    Tcl_ThreadId id)		/* The thread to remember as joinable */
{
    JoinableThread *threadPtr;

    threadPtr = (JoinableThread *)Tcl_Alloc(sizeof(JoinableThread));
    threadPtr->id = id;
    threadPtr->done = 0;
    threadPtr->waitedUpon = 0;
    threadPtr->threadMutex = (Tcl_Mutex) NULL;
    threadPtr->cond = (Tcl_Condition) NULL;

    Tcl_MutexLock(&joinMutex);

    threadPtr->nextThreadPtr = firstThreadPtr;
    firstThreadPtr = threadPtr;







|
|







228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
TclRememberJoinableThread(
    Tcl_ThreadId id)		/* The thread to remember as joinable */
{
    JoinableThread *threadPtr;

    threadPtr = (JoinableThread *)Tcl_Alloc(sizeof(JoinableThread));
    threadPtr->id = id;
    threadPtr->done = false;
    threadPtr->waitedUpon = false;
    threadPtr->threadMutex = (Tcl_Mutex) NULL;
    threadPtr->cond = (Tcl_Condition) NULL;

    Tcl_MutexLock(&joinMutex);

    threadPtr->nextThreadPtr = firstThreadPtr;
    firstThreadPtr = threadPtr;
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
     * that it exists. The order of lock/unlock ensures that a thread entering
     * 'TclJoinThread' will not interfere with us.
     */

    Tcl_MutexLock(&threadPtr->threadMutex);
    Tcl_MutexUnlock(&joinMutex);

    threadPtr->done = 1;
    threadPtr->result = result;

    if (threadPtr->waitedUpon) {
	Tcl_ConditionNotify(&threadPtr->cond);
    }

    Tcl_MutexUnlock(&threadPtr->threadMutex);







|







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
     * that it exists. The order of lock/unlock ensures that a thread entering
     * 'TclJoinThread' will not interfere with us.
     */

    Tcl_MutexLock(&threadPtr->threadMutex);
    Tcl_MutexUnlock(&joinMutex);

    threadPtr->done = true;
    threadPtr->result = result;

    if (threadPtr->waitedUpon) {
	Tcl_ConditionNotify(&threadPtr->cond);
    }

    Tcl_MutexUnlock(&threadPtr->threadMutex);
Changes to generic/tclThreadTest.c.
48
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63

static ThreadSpecificData *threadList = NULL;

/*
 * The following bit-values are legal for the "flags" field of the
 * ThreadSpecificData structure.
 */

#define TP_Dying		0x001 /* This thread is being canceled */


/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the ThreadCreate() C function.
 */








|
|
>







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

static ThreadSpecificData *threadList = NULL;

/*
 * The following bit-values are legal for the "flags" field of the
 * ThreadSpecificData structure.
 */
enum TSDFlags {
    TP_Dying = 0x001		/* This thread is being canceled */
};

/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the ThreadCreate() C function.
 */

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
 * this mutex.
 */

TCL_DECLARE_MUTEX(threadMutex)

static Tcl_ObjCmdProc ThreadCmd;
static int		ThreadCreate(Tcl_Interp *interp, const char *script,
			    int joinable);
static int		ThreadList(Tcl_Interp *interp);
static int		ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
			    const char *script, int wait);
static int		ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
			    const char *result, int flags);

static Tcl_ThreadCreateType	NewTestThread(void *clientData);
static void		ListRemove(ThreadSpecificData *tsdPtr);
static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
static int		ThreadEventProc(Tcl_Event *evPtr, int mask);







|


|







117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 * this mutex.
 */

TCL_DECLARE_MUTEX(threadMutex)

static Tcl_ObjCmdProc ThreadCmd;
static int		ThreadCreate(Tcl_Interp *interp, const char *script,
			    bool joinable);
static int		ThreadList(Tcl_Interp *interp);
static int		ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
			    const char *script, bool wait);
static int		ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
			    const char *result, int flags);

static Tcl_ThreadCreateType	NewTestThread(void *clientData);
static void		ListRemove(ThreadSpecificData *tsdPtr);
static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
static int		ThreadEventProc(Tcl_Event *evPtr, int mask);
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
	} else {
	    result = NULL;
	}
	return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
    }
    case THREAD_CREATE: {
	const char *script;
	int joinable;
	Tcl_Size len;

	if (objc == 2) {
	    /*
	     * Neither joinable nor special script
	     */

	    joinable = 0;
	    script = "testthread wait";		/* Just enter event loop */
	} else if (objc == 3) {
	    /*
	     * Possibly -joinable, then no special script, no joinable, then
	     * its a script.
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);

	    if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
		    (0 == strncmp(script, "-joinable", len))) {
		joinable = 1;
		script = "testthread wait";	/* Just enter event loop */
	    } else {
		/*
		 * Remember the script
		 */

		joinable = 0;
	    }
	} else if (objc == 4) {
	    /*
	     * Definitely a script available, but is the flag -joinable?
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);







|







|











|






|







274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
	} else {
	    result = NULL;
	}
	return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
    }
    case THREAD_CREATE: {
	const char *script;
	bool joinable;
	Tcl_Size len;

	if (objc == 2) {
	    /*
	     * Neither joinable nor special script
	     */

	    joinable = false;
	    script = "testthread wait";		/* Just enter event loop */
	} else if (objc == 3) {
	    /*
	     * Possibly -joinable, then no special script, no joinable, then
	     * its a script.
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);

	    if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
		    (0 == strncmp(script, "-joinable", len))) {
		joinable = true;
		script = "testthread wait";	/* Just enter event loop */
	    } else {
		/*
		 * Remember the script
		 */

		joinable = false;
	    }
	} else if (objc == 4) {
	    /*
	     * Definitely a script available, but is the flag -joinable?
	     */

	    script = Tcl_GetStringFromObj(objv[2], &len);
381
382
383
384
385
386
387

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return ThreadList(interp);
    case THREAD_SEND: {
	Tcl_WideInt id;
	const char *script;

	int wait, arg;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
		return TCL_ERROR;
	    }
	    wait = 0;
	    arg = 3;
	} else {
	    wait = 1;
	    arg = 2;
	}
	if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
	    return TCL_ERROR;
	}
	arg++;
	script = Tcl_GetString(objv[arg]);







>
|










|


|







382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}
	return ThreadList(interp);
    case THREAD_SEND: {
	Tcl_WideInt id;
	const char *script;
	int arg;
	bool wait;

	if ((objc != 4) && (objc != 5)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
	    return TCL_ERROR;
	}
	if (objc == 5) {
	    if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
		Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
		return TCL_ERROR;
	    }
	    wait = false;
	    arg = 3;
	} else {
	    wait = true;
	    arg = 2;
	}
	if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
	    return TCL_ERROR;
	}
	arg++;
	script = Tcl_GetString(objv[arg]);
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
 *----------------------------------------------------------------------
 */

static int
ThreadCreate(
    Tcl_Interp *interp,		/* Current interpreter. */
    const char *script,		/* Script to execute */
    int joinable)		/* Flag, joinable thread or not */
{
    ThreadCtrl ctrl;
    Tcl_ThreadId id;

    ctrl.script = script;
    ctrl.condWait = NULL;
    ctrl.flags = 0;

    joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
	    TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "cannot create a new thread");
	return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using something on our stack!







|








|



|







493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
 *----------------------------------------------------------------------
 */

static int
ThreadCreate(
    Tcl_Interp *interp,		/* Current interpreter. */
    const char *script,		/* Script to execute */
    bool joinable)		/* Flag, joinable thread or not */
{
    ThreadCtrl ctrl;
    Tcl_ThreadId id;

    ctrl.script = script;
    ctrl.condWait = NULL;
    ctrl.flags = 0;

    int flags = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
	    TCL_THREAD_STACK_DEFAULT, flags) != TCL_OK) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "cannot create a new thread");
	return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using something on our stack!
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	Tcl_WriteChars(errChannel, errorInfo, -1);
	Tcl_WriteChars(errChannel, "\n", 1);
    } else {
	argv[0] = errorProcString;
	argv[1] = buf;
	argv[2] = errorInfo;
	script = Tcl_Merge(3, argv);
	ThreadSend(interp, errorThreadId, script, 0);
	Tcl_Free(script);
    }
}

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







|







666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
	Tcl_WriteChars(errChannel, errorInfo, -1);
	Tcl_WriteChars(errChannel, "\n", 1);
    } else {
	argv[0] = errorProcString;
	argv[1] = buf;
	argv[2] = errorInfo;
	script = Tcl_Merge(3, argv);
	ThreadSend(interp, errorThreadId, script, false);
	Tcl_Free(script);
    }
}


/*
 *------------------------------------------------------------------------
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
 */

static int
ThreadSend(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_ThreadId id,		/* Thread Id of other interpreter. */
    const char *script,		/* The script to evaluate. */
    int wait)			/* If 1, we block for the result. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr;
    ThreadEventResult *resultPtr;
    int found, code;
    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /*
     * Verify the thread exists.
     */

    Tcl_MutexLock(&threadMutex);
    found = 0;
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    found = 1;
	    break;
	}
    }
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "invalid thread id");
	return TCL_ERROR;







|




<







|


|







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
 */

static int
ThreadSend(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_ThreadId id,		/* Thread Id of other interpreter. */
    const char *script,		/* The script to evaluate. */
    bool wait)			/* If true, we block for the result. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr;
    ThreadEventResult *resultPtr;

    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /*
     * Verify the thread exists.
     */

    Tcl_MutexLock(&threadMutex);
    bool found = false;
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    found = true;
	    break;
	}
    }
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "invalid thread id");
	return TCL_ERROR;
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
	if (resultPtr->errorInfo) {
	    Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
	    Tcl_Free(resultPtr->errorInfo);
	}
    }
    TclAppendResult(interp, resultPtr->result);
    Tcl_ConditionFinalize(&resultPtr->done);
    code = resultPtr->code;

    Tcl_Free(resultPtr->result);
    Tcl_Free(resultPtr);

    return code;
}








|







922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
	if (resultPtr->errorInfo) {
	    Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
	    Tcl_Free(resultPtr->errorInfo);
	}
    }
    TclAppendResult(interp, resultPtr->result);
    Tcl_ConditionFinalize(&resultPtr->done);
    int code = resultPtr->code;

    Tcl_Free(resultPtr->result);
    Tcl_Free(resultPtr);

    return code;
}

953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
ThreadCancel(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_ThreadId id,		/* Thread Id of other interpreter. */
    const char *result,		/* The result or NULL for default. */
    int flags)			/* Flags for Tcl_CancelEval. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int found;
    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /*
     * Verify the thread exists.
     */

    Tcl_MutexLock(&threadMutex);
    found = 0;
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    found = 1;
	    break;
	}
    }
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "invalid thread id");
	return TCL_ERROR;







<







|


|







954
955
956
957
958
959
960

961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
ThreadCancel(
    Tcl_Interp *interp,		/* The current interpreter. */
    Tcl_ThreadId id,		/* Thread Id of other interpreter. */
    const char *result,		/* The result or NULL for default. */
    int flags)			/* Flags for Tcl_CancelEval. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /*
     * Verify the thread exists.
     */

    Tcl_MutexLock(&threadMutex);
    bool found = false;
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
	if (tsdPtr->threadId == threadId) {
	    found = true;
	    break;
	}
    }
    if (!found) {
	Tcl_MutexUnlock(&threadMutex);
	TclPrintfResult(interp, "invalid thread id");
	return TCL_ERROR;
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
	}
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&threadMutex);
    }
    if (interp != NULL) {
	Tcl_Release(interp);
    }
    return 1;
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadFreeProc --
 *







|







1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
	}
	Tcl_ConditionNotify(&resultPtr->done);
	Tcl_MutexUnlock(&threadMutex);
    }
    if (interp != NULL) {
	Tcl_Release(interp);
    }
    return true;
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadFreeProc --
 *
Changes to generic/tclTimer.c.
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData_Timer {
    TimerHandler *firstTimerHandlerPtr;	/* First event in queue. */
    int lastTimerId;		/* Timer identifier of most recently created
				 * timer. */
    int timerPending;		/* 1 if a timer event is in the queue. */
    IdleHandler *idleList;	/* First in list of all idle handlers. */
    IdleHandler *lastIdlePtr;	/* Last in list (or NULL for empty list). */
    int idleGeneration;		/* Used to fill in the "generation" fields of
				 * IdleHandler structures. Increments each
				 * time Tcl_DoOneEvent starts calling idle
				 * handlers, so that all old handlers can be
				 * called without calling any of the new ones







|







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
 * The structure defined below is used in this file only.
 */

typedef struct ThreadSpecificData_Timer {
    TimerHandler *firstTimerHandlerPtr;	/* First event in queue. */
    int lastTimerId;		/* Timer identifier of most recently created
				 * timer. */
    bool timerPending;		/* True if a timer event is in the queue. */
    IdleHandler *idleList;	/* First in list of all idle handlers. */
    IdleHandler *lastIdlePtr;	/* Last in list (or NULL for empty list). */
    int idleGeneration;		/* Used to fill in the "generation" fields of
				 * IdleHandler structures. Increments each
				 * time Tcl_DoOneEvent starts calling idle
				 * handlers, so that all old handlers can be
				 * called without calling any of the new ones
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

	/*
	 * If the first timer has expired, stick an event on the queue.
	 */

	if (blockTime.sec == 0 && blockTime.usec == 0 &&
		!tsdPtr->timerPending) {
	    tsdPtr->timerPending = 1;
	    Tcl_Event *timerEvPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event));
	    timerEvPtr->proc = TimerHandlerEventProc;
	    Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
	}
    }
}








|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

	/*
	 * If the first timer has expired, stick an event on the queue.
	 */

	if (blockTime.sec == 0 && blockTime.usec == 0 &&
		!tsdPtr->timerPending) {
	    tsdPtr->timerPending = true;
	    Tcl_Event *timerEvPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event));
	    timerEvPtr->proc = TimerHandlerEventProc;
	    Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
	}
    }
}

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
    /*
     * Do nothing if timers aren't enabled. This leaves the event on the
     * queue, so we will get to it as soon as ServiceEvents() is called with
     * timers enabled.
     */

    if (!(flags & TCL_TIMER_EVENTS)) {
	return 0;
    }

    /*
     * The code below is trickier than it may look, for the following reasons:
     *
     * 1. New handlers can get added to the list while the current one is
     *	  being processed. If new ones get added, we don't want to process







|







528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
    /*
     * Do nothing if timers aren't enabled. This leaves the event on the
     * queue, so we will get to it as soon as ServiceEvents() is called with
     * timers enabled.
     */

    if (!(flags & TCL_TIMER_EVENTS)) {
	return false;
    }

    /*
     * The code below is trickier than it may look, for the following reasons:
     *
     * 1. New handlers can get added to the list while the current one is
     *	  being processed. If new ones get added, we don't want to process
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
     *	  This is fairly likely on Windows, since it has a course granularity
     *	  clock. Since timers are placed on the queue in time order with the
     *	  most recently created handler appearing after earlier ones with the
     *	  same expiration time, we don't have to worry about newer generation
     *	  timers appearing before later ones.
     */

    tsdPtr->timerPending = 0;
    int currentTimerId = tsdPtr->lastTimerId;
    Tcl_GetTime(&time);
    while (1) {
	TimerHandler *timerHandlerPtr, **nextPtrPtr;
	nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	if (timerHandlerPtr == NULL) {







|







556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
     *	  This is fairly likely on Windows, since it has a course granularity
     *	  clock. Since timers are placed on the queue in time order with the
     *	  most recently created handler appearing after earlier ones with the
     *	  same expiration time, we don't have to worry about newer generation
     *	  timers appearing before later ones.
     */

    tsdPtr->timerPending = false;
    int currentTimerId = tsdPtr->lastTimerId;
    Tcl_GetTime(&time);
    while (1) {
	TimerHandler *timerHandlerPtr, **nextPtrPtr;
	nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
	if (timerHandlerPtr == NULL) {
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
	 */

	*nextPtrPtr = timerHandlerPtr->nextPtr;
	timerHandlerPtr->proc(timerHandlerPtr->clientData);
	Tcl_Free(timerHandlerPtr);
    }
    TimerSetupProc(NULL, TCL_TIMER_EVENTS);
    return 1;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DoWhenIdle --
 *







|







589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
	 */

	*nextPtrPtr = timerHandlerPtr->nextPtr;
	timerHandlerPtr->proc(timerHandlerPtr->clientData);
	Tcl_Free(timerHandlerPtr);
    }
    TimerSetupProc(NULL, TCL_TIMER_EVENTS);
    return true;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_DoWhenIdle --
 *
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720

int
TclServiceIdle(void)
{
    ThreadSpecificData *tsdPtr = InitTimer();

    if (tsdPtr->idleList == NULL) {
	return 0;
    }

    int oldGeneration = tsdPtr->idleGeneration;
    tsdPtr->idleGeneration++;

    /*
     * The code below is trickier than it may look, for the following reasons:







|







706
707
708
709
710
711
712
713
714
715
716
717
718
719
720

int
TclServiceIdle(void)
{
    ThreadSpecificData *tsdPtr = InitTimer();

    if (tsdPtr->idleList == NULL) {
	return false;
    }

    int oldGeneration = tsdPtr->idleGeneration;
    tsdPtr->idleGeneration++;

    /*
     * The code below is trickier than it may look, for the following reasons:
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
    }
    if (tsdPtr->idleList) {
	Tcl_Time blockTime;
	blockTime.sec = 0;
	blockTime.usec = 0;
	Tcl_SetMaxBlockTime(&blockTime);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AfterObjCmd --
 *







|







746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
    }
    if (tsdPtr->idleList) {
	Tcl_Time blockTime;
	blockTime.sec = 0;
	blockTime.usec = 0;
	Tcl_SetMaxBlockTime(&blockTime);
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AfterObjCmd --
 *
Changes to generic/tclTrace.c.
1041
1042
1043
1044
1045
1046
1047
1048
1049
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
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
				 * of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc,	/* Function assocated with trace. */
    void *clientData)		/* Arbitrary argument to pass to proc. */
{
    CommandTrace *tracePtr, *prevPtr;
    Interp *iPtr = (Interp *)interp;
    int hasExecTraces = 0;

    Command *cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
	    TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);

    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
	    prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc)
		&& ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE |
			TCL_TRACE_ANY_EXEC)) == flags)
		&& (tracePtr->clientData == clientData)) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		hasExecTraces = 1;
	    }
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces are







|



















|







1041
1042
1043
1044
1045
1046
1047
1048
1049
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
				 * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
				 * of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc,	/* Function assocated with trace. */
    void *clientData)		/* Arbitrary argument to pass to proc. */
{
    CommandTrace *tracePtr, *prevPtr;
    Interp *iPtr = (Interp *)interp;
    bool hasExecTraces = false;

    Command *cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
	    TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);

    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
	    prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc)
		&& ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE |
			TCL_TRACE_ANY_EXEC)) == flags)
		&& (tracePtr->clientData == clientData)) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		hasExecTraces = true;
	    }
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces are
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
	    (traceCode == TCL_OK) && (tracePtr != NULL);
	    tracePtr = active.nextTracePtr) {
	if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
	    /*
	     * Execute the trace command in order of creation for "leave".
	     */

	    active.reverseScan = 1;
	    active.nextTracePtr = NULL;
	    tracePtr = cmdPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = 0;
	    active.nextTracePtr = tracePtr->nextPtr;
	}
	if (tracePtr->traceProc == TraceCommandProc) {
	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;

	    if (tcmdPtr->flags != 0) {
		tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;







|







|







1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
	    (traceCode == TCL_OK) && (tracePtr != NULL);
	    tracePtr = active.nextTracePtr) {
	if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
	    /*
	     * Execute the trace command in order of creation for "leave".
	     */

	    active.reverseScan = true;
	    active.nextTracePtr = NULL;
	    tracePtr = cmdPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = false;
	    active.nextTracePtr = tracePtr->nextPtr;
	}
	if (tracePtr->traceProc == TraceCommandProc) {
	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;

	    if (tcmdPtr->flags != 0) {
		tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
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
	     * "enterstep" operation. The order is changed for "enterstep"
	     * instead of for "leavestep" as was done in
	     * TclCheckExecutionTraces because for step traces,
	     * Tcl_CreateObjTrace creates one more linked list of traces which
	     * results in one more reversal of trace invocation.
	     */

	    active.reverseScan = 1;
	    active.nextTracePtr = NULL;
	    tracePtr = iPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	    if (active.nextTracePtr) {
		lastTracePtr = active.nextTracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = 0;
	    active.nextTracePtr = tracePtr->nextPtr;
	}

	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
	    continue;
	}








|










|







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
	     * "enterstep" operation. The order is changed for "enterstep"
	     * instead of for "leavestep" as was done in
	     * TclCheckExecutionTraces because for step traces,
	     * Tcl_CreateObjTrace creates one more linked list of traces which
	     * results in one more reversal of trace invocation.
	     */

	    active.reverseScan = true;
	    active.nextTracePtr = NULL;
	    tracePtr = iPtr->tracePtr;
	    while (tracePtr->nextPtr != lastTracePtr) {
		active.nextTracePtr = tracePtr;
		tracePtr = tracePtr->nextPtr;
	    }
	    if (active.nextTracePtr) {
		lastTracePtr = active.nextTracePtr->nextPtr;
	    }
	} else {
	    active.reverseScan = false;
	    active.nextTracePtr = tracePtr->nextPtr;
	}

	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
	    continue;
	}

1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
    Tcl_Interp *interp,
    Tcl_Size level,
    const char *command,
    TCL_UNUSED(Tcl_Command),
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    int call = 0;
    Interp *iPtr = (Interp *) interp;
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
    int flags = tcmdPtr->curFlags;
    int code = tcmdPtr->curCode;
    int traceCode = TCL_OK;

    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {







|







1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
    Tcl_Interp *interp,
    Tcl_Size level,
    const char *command,
    TCL_UNUSED(Tcl_Command),
    Tcl_Size objc,
    Tcl_Obj *const objv[])
{
    bool call = false;
    Interp *iPtr = (Interp *) interp;
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
    int flags = tcmdPtr->curFlags;
    int code = tcmdPtr->curCode;
    int traceCode = TCL_OK;

    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
	 * before or after operations, but with either of the step operations.
	 */

	if (flags & TCL_TRACE_EXEC_DIRECT) {
	    call = flags & tcmdPtr->flags &
		    (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	} else {
	    call = 1;
	}

	/*
	 * First, if we have returned back to the level at which we created an
	 * interpreter trace for enterstep and/or leavestep execution traces,
	 * we remove it here.
	 */







|







1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
	 * before or after operations, but with either of the step operations.
	 */

	if (flags & TCL_TRACE_EXEC_DIRECT) {
	    call = flags & tcmdPtr->flags &
		    (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	} else {
	    call = true;
	}

	/*
	 * First, if we have returned back to the level at which we created an
	 * interpreter trace for enterstep and/or leavestep execution traces,
	 * we remove it here.
	 */
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
    const char *name1,		/* Name of variable or array. */
    const char *name2,		/* Name of element within array; NULL means
				 * scalar variable is being referenced. */
    int flags)			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
    int destroy = 0;
    Tcl_DString cmd;
    int rewind = ((Interp *)interp)->execEnvPtr->rewind;

    /*
     * We might call Tcl_EvalEx() below, and that might evaluate
     * [trace remove variable] which might try to free tvarPtr. We want to
     * use tvarPtr until the end of this function, so we use Tcl_Preserve()
     * and Tcl_Release() to be sure it is not freed while we still need it.
     */







|

<







1821
1822
1823
1824
1825
1826
1827
1828
1829

1830
1831
1832
1833
1834
1835
1836
    const char *name1,		/* Name of variable or array. */
    const char *name2,		/* Name of element within array; NULL means
				 * scalar variable is being referenced. */
    int flags)			/* OR-ed bits giving operation and other
				 * information. */
{
    TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
    bool destroy = false, rewind = ((Interp *)interp)->execEnvPtr->rewind;
    Tcl_DString cmd;


    /*
     * We might call Tcl_EvalEx() below, and that might evaluate
     * [trace remove variable] which might try to free tvarPtr. We want to
     * use tvarPtr until the end of this function, so we use Tcl_Preserve()
     * and Tcl_Release() to be sure it is not freed while we still need it.
     */
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
	     * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
	     * other areas that this will be destroyed by us, otherwise a
	     * double-free might occur depending on what the eval does.
	     */

	    if ((flags & TCL_TRACE_DESTROYED)
		    && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
		destroy = 1;
		tvarPtr->flags |= TCL_TRACE_DESTROYED;
	    }

	    /*
	     * Make sure that unset traces are rune even if the execEnv is
	     * rewinding (coroutine deletion, [Bug 2093947]
	     */

	    if (rewind && (flags & TCL_TRACE_UNSETS)) {
		((Interp *)interp)->execEnvPtr->rewind = 0;
	    }
	    int code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		    Tcl_DStringLength(&cmd), 0);
	    if (rewind) {
		((Interp *)interp)->execEnvPtr->rewind = rewind;
	    }
	    if (code != TCL_OK) {		/* copy error msg to result */







|









|







1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
	     * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
	     * other areas that this will be destroyed by us, otherwise a
	     * double-free might occur depending on what the eval does.
	     */

	    if ((flags & TCL_TRACE_DESTROYED)
		    && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
		destroy = true;
		tvarPtr->flags |= TCL_TRACE_DESTROYED;
	    }

	    /*
	     * Make sure that unset traces are rune even if the execEnv is
	     * rewinding (coroutine deletion, [Bug 2093947]
	     */

	    if (rewind && (flags & TCL_TRACE_UNSETS)) {
		((Interp *)interp)->execEnvPtr->rewind = false;
	    }
	    int code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
		    Tcl_DStringLength(&cmd), 0);
	    if (rewind) {
		((Interp *)interp)->execEnvPtr->rewind = rewind;
	    }
	    if (code != TCL_OK) {		/* copy error msg to result */
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
    int code = TCL_OK;

    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	Interp *iPtr = (Interp *)interp;

	code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
		(TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY),
		/* leaveErrMsg */ 1, index);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|
|







2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
    int code = TCL_OK;

    if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	Interp *iPtr = (Interp *)interp;

	code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
		(TCL_NAMESPACE_ONLY | TCL_GLOBAL_ONLY | TCL_TRACE_ARRAY),
		/* leaveErrMsg */ true, index);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
 *
 *----------------------------------------------------------------------
 */

int
TclObjCallVarTraces(
    Interp *iPtr,		/* Interpreter containing variable. */
    Var *arrayPtr,	/* Pointer to array variable that contains the
				 * variable, or NULL if the variable isn't an
				 * element of an array. */
    Var *varPtr,		/* Variable whose traces are to be invoked. */
    Tcl_Obj *part1Ptr,
    Tcl_Obj *part2Ptr,		/* Variable's two-part name. */
    int flags,			/* Flags passed to trace functions: indicates
				 * what's happening to variable, plus maybe
				 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
    int leaveErrMsg,		/* If true, and one of the traces indicates an
				 * error, then leave an error message and
				 * stack trace information in *iPTr. */
    Tcl_Size index)		/* Index into the local variable table of the
				 * variable, or -1. Only used when part1Ptr is
				 * NULL. */
{
    const char *part1, *part2;







|








|







2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
 *
 *----------------------------------------------------------------------
 */

int
TclObjCallVarTraces(
    Interp *iPtr,		/* Interpreter containing variable. */
    Var *arrayPtr,		/* Pointer to array variable that contains the
				 * variable, or NULL if the variable isn't an
				 * element of an array. */
    Var *varPtr,		/* Variable whose traces are to be invoked. */
    Tcl_Obj *part1Ptr,
    Tcl_Obj *part2Ptr,		/* Variable's two-part name. */
    int flags,			/* Flags passed to trace functions: indicates
				 * what's happening to variable, plus maybe
				 * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
    bool leaveErrMsg,		/* If true, and one of the traces indicates an
				 * error, then leave an error message and
				 * stack trace information in *iPTr. */
    Tcl_Size index)		/* Index into the local variable table of the
				 * variable, or -1. Only used when part1Ptr is
				 * NULL. */
{
    const char *part1, *part2;
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
     * If the variable name hasn't been parsed into array name and element, do
     * it here. If there really is an array element, make a copy of the
     * original name so that NULLs can be inserted into it to separate the
     * names (can't modify the name string in place, because the string might
     * get used by the callbacks we invoke).
     */

    int copiedName = 0;
    if (part2 == NULL) {
	for (const char *p = part1; *p ; p++) {
	    if (*p == '(') {
		const char *openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    Tcl_Size offset = openParen - part1;

		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, p-part1);
		    char *newPart1 = Tcl_DStringValue(&nameCopy);
		    newPart1[offset] = 0;
		    part1 = newPart1;
		    part2 = newPart1 + offset + 1;
		    copiedName = 1;
		}
		break;
	    }
	}
    }

    /* Keep the original pointer for possible use in an error message */







|

















|







2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
     * If the variable name hasn't been parsed into array name and element, do
     * it here. If there really is an array element, make a copy of the
     * original name so that NULLs can be inserted into it to separate the
     * names (can't modify the name string in place, because the string might
     * get used by the callbacks we invoke).
     */

    bool copiedName = false;
    if (part2 == NULL) {
	for (const char *p = part1; *p ; p++) {
	    if (*p == '(') {
		const char *openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    Tcl_Size offset = openParen - part1;

		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, p-part1);
		    char *newPart1 = Tcl_DStringValue(&nameCopy);
		    newPart1[offset] = 0;
		    part1 = newPart1;
		    part2 = newPart1 + offset + 1;
		    copiedName = true;
		}
		break;
	    }
	}
    }

    /* Keep the original pointer for possible use in an error message */
Changes to generic/tclUtf.c.
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
    3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};

/*
 * Functions used only in this module.
 */

static int		Invalid(const char *src);

/*
 *---------------------------------------------------------------------------
 *
 * TclUtfCount --
 *
 *	Find the number of bytes in the Utf character "ch".







|







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
    3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};

/*
 * Functions used only in this module.
 */

static bool		Invalid(const char *src);

/*
 *---------------------------------------------------------------------------
 *
 * TclUtfCount --
 *
 *	Find the number of bytes in the Utf character "ch".
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
    0x80, 0xBF,		/* (\xC4 - \xDC) -- all sequences valid */
    0xA0, 0xBF,	/* \xE0\x80 through \xE0\x9F are invalid prefixes */
    0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
    0x90, 0xBF,	/* \xF0\x80 through \xF0\x8F are invalid prefixes */
    0x80, 0x8F  /* \xF4\x90 and higher are invalid prefixes */
};

static int
Invalid(
    const char *src)	/* Points to lead byte of a UTF-8 byte sequence */
{
    unsigned char byte = UCHAR(*src);
    int index;

    if ((byte & 0xC3) == 0xC0) {
	/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
	index = (byte - 0xC0) >> 1;
	if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) {
	    /* Out of bounds - report invalid. */
	    return 1;
	}
    }
    return 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtf --
 *







|











|


|







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
    0x80, 0xBF,		/* (\xC4 - \xDC) -- all sequences valid */
    0xA0, 0xBF,	/* \xE0\x80 through \xE0\x9F are invalid prefixes */
    0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
    0x90, 0xBF,	/* \xF0\x80 through \xF0\x8F are invalid prefixes */
    0x80, 0x8F  /* \xF4\x90 and higher are invalid prefixes */
};

static bool
Invalid(
    const char *src)	/* Points to lead byte of a UTF-8 byte sequence */
{
    unsigned char byte = UCHAR(*src);
    int index;

    if ((byte & 0xC3) == 0xC0) {
	/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
	index = (byte - 0xC0) >> 1;
	if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) {
	    /* Out of bounds - report invalid. */
	    return true;
	}
    }
    return false;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_UniCharToUtf --
 *
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
     * UTF-8 string length in bytes will be <= Utf16 string length * 3.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength < 0) {

	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}
    }







<







366
367
368
369
370
371
372

373
374
375
376
377
378
379
     * UTF-8 string length in bytes will be <= Utf16 string length * 3.
     */

    if (uniStr == NULL) {
	return NULL;
    }
    if (uniLength < 0) {

	uniLength = 0;
	w = uniStr;
	while (*w != '\0') {
	    uniLength++;
	    w++;
	}
    }
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534

    *chPtr = byte;
    return 1;
}

Tcl_Size
Tcl_UtfToChar16(
    const char *src,	/* The UTF-8 string. */
    unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
				 * the UTF-8 string. This could be a surrogate too. */
{
    unsigned short byte;

    /*
     * Unroll 1 to 4 byte UTF-8 sequences.
     */







|
|







518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

    *chPtr = byte;
    return 1;
}

Tcl_Size
Tcl_UtfToChar16(
    const char *src,		/* The UTF-8 string. */
    unsigned short *chPtr)	/* Filled with the Tcl_UniChar represented by
				 * the UTF-8 string. This could be a surrogate too. */
{
    unsigned short byte;

    /*
     * Unroll 1 to 4 byte UTF-8 sequences.
     */
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
 *----------------------------------------------------------------------
 */

int
TclpUtfNcmp2(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numBytes)	/* Number of *bytes* to compare. */
{
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;
    /*
     * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to
     * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes
     * fine in the strcmp manner.







|







1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
 *----------------------------------------------------------------------
 */

int
TclpUtfNcmp2(
    const void *csPtr,		/* UTF string to compare to ct. */
    const void *ctPtr,		/* UTF string cs is compared to. */
    size_t numBytes)		/* Number of *bytes* to compare. */
{
    const char *cs = (const char *)csPtr;
    const char *ct = (const char *)ctPtr;
    /*
     * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to
     * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes
     * fine in the strcmp manner.
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
 *----------------------------------------------------------------------
 */

int
TclUtfNcmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of UTF-16 chars to compare. */
{
    unsigned short ch1 = 0, ch2 = 0;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
     * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
     * (the byte 0x01.)







|







1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
 *----------------------------------------------------------------------
 */

int
TclUtfNcmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of UTF-16 chars to compare. */
{
    unsigned short ch1 = 0, ch2 = 0;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
     * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
     * (the byte 0x01.)
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
    return 0;
}

int
Tcl_UtfNcmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
     * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
     * (the byte 0x01.)







|







1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
    return 0;
}

int
Tcl_UtfNcmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    /*
     * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
     * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
     * (the byte 0x01.)
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
 *----------------------------------------------------------------------
 */

int
TclUtfNcasecmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of UTF-16 chars to compare. */
{
    unsigned short ch1 = 0, ch2 = 0;

    while (numChars-- > 0) {
	/*
	 * n must be interpreted as UTF-16 chars, not bytes.
	 * This should be called only when both strings are of







|







1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
 *----------------------------------------------------------------------
 */

int
TclUtfNcasecmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of UTF-16 chars to compare. */
{
    unsigned short ch1 = 0, ch2 = 0;

    while (numChars-- > 0) {
	/*
	 * n must be interpreted as UTF-16 chars, not bytes.
	 * This should be called only when both strings are of
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
    return 0;
}

int
Tcl_UtfNcasecmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)	/* Number of chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    while (numChars-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of







|







1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
    return 0;
}

int
Tcl_UtfNcasecmp(
    const char *cs,		/* UTF string to compare to ct. */
    const char *ct,		/* UTF string cs is compared to. */
    size_t numChars)		/* Number of chars to compare. */
{
    Tcl_UniChar ch1 = 0, ch2 = 0;

    while (numChars-- > 0) {
	/*
	 * n must be interpreted as chars, not bytes.
	 * This should be called only when both strings are of
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_UniCharLen(
    const int *uniStr)	/* Unicode string to find length of. */
{
    Tcl_Size len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }







|







1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Size
Tcl_UniCharLen(
    const int *uniStr)		/* Unicode string to find length of. */
{
    Tcl_Size len = 0;

    while (*uniStr != '\0') {
	len++;
	uniStr++;
    }
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
 *----------------------------------------------------------------------
 */

int
TclUniCharNcmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    size_t numChars)	/* Number of chars to compare. */
{
#if defined(WORDS_BIGENDIAN)
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */

    return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));







|







1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
 *----------------------------------------------------------------------
 */

int
TclUniCharNcmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    size_t numChars)		/* Number of chars to compare. */
{
#if defined(WORDS_BIGENDIAN)
    /*
     * We are definitely on a big-endian machine; memcmp() is safe
     */

    return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
 *----------------------------------------------------------------------
 */

int
TclUniCharNcasecmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    size_t numChars)	/* Number of chars to compare. */
{
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {







|







1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
 *----------------------------------------------------------------------
 */

int
TclUniCharNcasecmp(
    const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
    const Tcl_UniChar *uct,	/* Unicode string ucs is compared to. */
    size_t numChars)		/* Number of chars to compare. */
{
    for ( ; numChars != 0; numChars--, ucs++, uct++) {
	if (*ucs != *uct) {
	    Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
	    Tcl_UniChar lct = Tcl_UniCharToLower(*uct);

	    if (lcs != lct) {
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
 */

int
Tcl_UniCharIsAlnum(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *







|







2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
 */

int
Tcl_UniCharIsAlnum(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
 */

int
Tcl_UniCharIsAlpha(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *







|







2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
 */

int
Tcl_UniCharIsAlpha(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
 */

int
Tcl_UniCharIsDigit(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}

/*
 *----------------------------------------------------------------------
 *







|







2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
 */

int
Tcl_UniCharIsDigit(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}

/*
 *----------------------------------------------------------------------
 *
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
 */

int
Tcl_UniCharIsLower(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == LOWERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *







|







2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
 */

int
Tcl_UniCharIsLower(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return (GetCategory(ch) == LOWERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
 */

int
Tcl_UniCharIsPunct(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *







|







2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
 */

int
Tcl_UniCharIsPunct(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return TclIsSpaceProcM((char) ch);
    } else if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
	    || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
	return 1;
    } else {
	return ((SPACE_BITS >> GetCategory(ch)) & 1);
    }
}

/*
 *----------------------------------------------------------------------







|


|







2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return TclIsSpaceProcM((char) ch);
    } else if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
	    || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
	return true;
    } else {
	return ((SPACE_BITS >> GetCategory(ch)) & 1);
    }
}

/*
 *----------------------------------------------------------------------
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
 */

int
Tcl_UniCharIsUpper(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return (GetCategory(ch) == UPPERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *







|







2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
 */

int
Tcl_UniCharIsUpper(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return (GetCategory(ch) == UPPERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329

2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
 */

int
Tcl_UniCharIsWordChar(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
    return ((WORD_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * TclUniCharCaseMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity. This is the Unicode equivalent of the char*
 *	Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated.
 *	This has no provision for counted UniChar strings, thus should not be
 *	used where NULLs are expected in the UniChar string. Use
 *	TclUniCharMatch where possible.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the
 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclUniCharCaseMatch(
    const Tcl_UniChar *uniStr,	/* Unicode String. */
    const Tcl_UniChar *uniPattern,
				/* Pattern, which may contain special
				 * characters. */
    int nocase)			/* 0 for case sensitive, 1 for insensitive */
{
    Tcl_UniChar ch1 = 0, p;

    while (1) {
	p = *uniPattern;

	/*
	 * See if we're at the end of both the pattern and the string. If so,
	 * we succeeded. If we're at the end of the pattern but not at the end
	 * of the string, we failed.
	 */

	if (p == 0) {
	    return (*uniStr == 0);
	}
	if ((*uniStr == 0) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++uniPattern) == '*') {
		/* empty body */
	    }
	    p = *uniPattern;
	    if (p == 0) {
		return 1;
	    }
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string







|

















|
|








<
>





|
















|




















|







2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327

2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
 */

int
Tcl_UniCharIsWordChar(
    int ch)			/* Unicode character to test. */
{
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return false;
    }
    return ((WORD_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * TclUniCharCaseMatch --
 *
 *	See if a particular Unicode string matches a particular pattern.
 *	Allows case insensitivity. This is the Unicode equivalent of the char*
 *	Tcl_StringCaseMatch. The UniChar strings must be NULL-terminated.
 *	This has no provision for counted UniChar strings, thus should not be
 *	used where NULLs are expected in the UniChar string. Use
 *	TclUniCharMatch where possible.
 *
 * Results:
 *	The return value is true if string matches pattern, false otherwise.
 *	The matching operation permits the following special characters in the
 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclUniCharCaseMatch(
    const Tcl_UniChar *uniStr,	/* Unicode String. */
    const Tcl_UniChar *uniPattern,
				/* Pattern, which may contain special
				 * characters. */
    bool nocase)		/* false for case sensitive, true for insensitive */
{
    Tcl_UniChar ch1 = 0, p;

    while (1) {
	p = *uniPattern;

	/*
	 * See if we're at the end of both the pattern and the string. If so,
	 * we succeeded. If we're at the end of the pattern but not at the end
	 * of the string, we failed.
	 */

	if (p == 0) {
	    return (*uniStr == 0);
	}
	if ((*uniStr == 0) && (p != '*')) {
	    return false;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++uniPattern) == '*') {
		/* empty body */
	    }
	    p = *uniPattern;
	    if (p == 0) {
		return true;
	    }
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
		    } else {
			while (*uniStr && (p != *uniStr)) {
			    uniStr++;
			}
		    }
		}
		if (TclUniCharCaseMatch(uniStr, uniPattern, nocase)) {
		    return 1;
		}
		if (*uniStr == 0) {
		    return 0;
		}
		uniStr++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any







|


|







2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
		    } else {
			while (*uniStr && (p != *uniStr)) {
			    uniStr++;
			}
		    }
		}
		if (TclUniCharCaseMatch(uniStr, uniPattern, nocase)) {
		    return true;
		}
		if (*uniStr == 0) {
		    return false;
		}
		uniStr++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
	    Tcl_UniChar startChar, endChar;

	    uniPattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
	    uniStr++;
	    while (1) {
		if ((*uniPattern == ']') || (*uniPattern == 0)) {
		    return 0;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			: *uniPattern);
		uniPattern++;
		if (*uniPattern == '-') {
		    uniPattern++;
		    if (*uniPattern == 0) {
			return 0;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			    : *uniPattern);
		    uniPattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*







|







|







2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
	    Tcl_UniChar startChar, endChar;

	    uniPattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
	    uniStr++;
	    while (1) {
		if ((*uniPattern == ']') || (*uniPattern == 0)) {
		    return false;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			: *uniPattern);
		uniPattern++;
		if (*uniPattern == '-') {
		    uniPattern++;
		    if (*uniPattern == 0) {
			return false;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
			    : *uniPattern);
		    uniPattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (*(++uniPattern) == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*uniStr) !=
		    Tcl_UniCharToLower(*uniPattern)) {
		return 0;
	    }
	} else if (*uniStr != *uniPattern) {
	    return 0;
	}
	uniStr++;
	uniPattern++;
    }
}

/*







|











|


|







2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (*(++uniPattern) == '\0') {
		return false;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*uniStr) !=
		    Tcl_UniCharToLower(*uniPattern)) {
		return false;
	    }
	} else if (*uniStr != *uniPattern) {
	    return false;
	}
	uniStr++;
	uniPattern++;
    }
}

/*
2537
2538
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
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern.
	     */

	    while (*(++pattern) == '*') {
		/* empty body */
	    }
	    if (pattern == patternEnd) {
		return 1;
	    }
	    p = *pattern;
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*







|



















|







2536
2537
2538
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
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return false;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern.
	     */

	    while (*(++pattern) == '*') {
		/* empty body */
	    }
	    if (pattern == patternEnd) {
		return true;
	    }
	    p = *pattern;
	    if (nocase) {
		p = Tcl_UniCharToLower(p);
	    }
	    while (1) {
		/*
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
			while ((string < stringEnd) && (p != *string)) {
			    string++;
			}
		    }
		}
		if (TclUniCharMatch(string, stringEnd - string,
			pattern, patternEnd - pattern, nocase)) {
		    return 1;
		}
		if (string == stringEnd) {
		    return 0;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any







|


|







2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
			while ((string < stringEnd) && (p != *string)) {
			    string++;
			}
		    }
		}
		if (TclUniCharMatch(string, stringEnd - string,
			pattern, patternEnd - pattern, nocase)) {
		    return true;
		}
		if (string == stringEnd) {
		    return false;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
	    Tcl_UniChar ch1, startChar, endChar;

	    pattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
	    string++;
	    while (1) {
		if ((*pattern == ']') || (pattern == patternEnd)) {
		    return 0;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
		pattern++;
		if (*pattern == '-') {
		    pattern++;
		    if (pattern == patternEnd) {
			return 0;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*pattern)
			    : *pattern);
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*







|






|







2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
	    Tcl_UniChar ch1, startChar, endChar;

	    pattern++;
	    ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
	    string++;
	    while (1) {
		if ((*pattern == ']') || (pattern == patternEnd)) {
		    return false;
		}
		startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
		pattern++;
		if (*pattern == '-') {
		    pattern++;
		    if (pattern == patternEnd) {
			return false;
		    }
		    endChar = (nocase ? Tcl_UniCharToLower(*pattern)
			    : *pattern);
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
		return 0;
	    }
	} else if (*string != *pattern) {
	    return 0;
	}
	string++;
	pattern++;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|










|


|













2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return false;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (nocase) {
	    if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
		return false;
	    }
	} else if (*string != *pattern) {
	    return false;
	}
	string++;
	pattern++;
    }
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to generic/tclUtil.c.
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
	goto done;
    }

    /*
     * No list element before leading white space.
     */

    count += 1 - TclIsSpaceProcM(*bytes);

    /*
     * Count white space runs as potential element separators.
     */

    while (numBytes) {
	if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) {







|







426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
	goto done;
    }

    /*
     * No list element before leading white space.
     */

    count += 1 - (int) TclIsSpaceProcM(*bytes);

    /*
     * Count white space runs as potential element separators.
     */

    while (numBytes) {
	if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) {
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
    const char *typeCode,	/* The type code for thing we are parsing, for
				 * error messages. */
    const char **elementPtr,	/* Where to put address of first significant
				 * character in first element. */
    const char **nextPtr,	/* Fill in with location of character just
				 * after all white space following end of
				 * argument (next arg or end of list/dict). */
    Tcl_Size *sizePtr,		/* If non-zero, fill in with size of
				 * element. */
    int *literalPtr)		/* If non-zero, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal list/dict element and therefore
				 * does not/does require a call to
				 * TclCopyAndCollapse() by the caller. */
{
    const char *p = string;
    const char *elemStart;	/* Points to first byte of first element. */
    const char *limit;		/* Points just after list/dict's last byte. */
    Tcl_Size openBraces = 0;	/* Brace nesting level during parse. */
    int inQuotes = 0;
    Tcl_Size size = 0;
    Tcl_Size numChars;
    int literal = 1;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
     * We treat embedded NULLs in the list/dict as bytes belonging to a list
     * element (or dictionary key or value).
     */

    limit = (string + stringLength);
    while ((p < limit) && (TclIsSpaceProcM(*p))) {
	p++;
    }
    if (p == limit) {		/* no element found */
	elemStart = limit;
	goto done;
    }

    if (*p == '{') {
	openBraces = 1;
	p++;
    } else if (*p == '"') {
	inQuotes = 1;
	p++;
    }
    elemStart = p;

    /*
     * Find element's end (a space, close brace, or the end of the string).
     */







|

|










|


|









|











|







585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
    const char *typeCode,	/* The type code for thing we are parsing, for
				 * error messages. */
    const char **elementPtr,	/* Where to put address of first significant
				 * character in first element. */
    const char **nextPtr,	/* Fill in with location of character just
				 * after all white space following end of
				 * argument (next arg or end of list/dict). */
    Tcl_Size *sizePtr,		/* If non-NULL, fill in with size of
				 * element. */
    int *literalPtr)		/* If non-NULL, fill in with non-zero/zero to
				 * indicate that the substring of *sizePtr
				 * bytes starting at **elementPtr is/is not
				 * the literal list/dict element and therefore
				 * does not/does require a call to
				 * TclCopyAndCollapse() by the caller. */
{
    const char *p = string;
    const char *elemStart;	/* Points to first byte of first element. */
    const char *limit;		/* Points just after list/dict's last byte. */
    Tcl_Size openBraces = 0;	/* Brace nesting level during parse. */
    bool inQuotes = false;
    Tcl_Size size = 0;
    Tcl_Size numChars;
    int literal = true;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
     * We treat embedded NULLs in the list/dict as bytes belonging to a list
     * element (or dictionary key or value).
     */

    limit = (string + stringLength);
    while ((p < limit) && TclIsSpaceProcM(*p)) {
	p++;
    }
    if (p == limit) {		/* no element found */
	elemStart = limit;
	goto done;
    }

    if (*p == '{') {
	openBraces = 1;
	p++;
    } else if (*p == '"') {
	inQuotes = true;
	p++;
    }
    elemStart = p;

    /*
     * Find element's end (a space, close brace, or the end of the string).
     */
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
		/*
		 * A backslash sequence not within a brace quoted element
		 * means the value of the element is different from the
		 * substring we are parsing. A call to TclCopyAndCollapse() is
		 * needed to produce the element value. Inform the caller.
		 */

		literal = 0;
	    }
	    TclParseBackslash(p, limit - p, &numChars, NULL);
	    p += (numChars - 1);
	    break;

	    /*
	     * Double-quote: if element is in quotes then terminate it.







|







693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
		/*
		 * A backslash sequence not within a brace quoted element
		 * means the value of the element is different from the
		 * substring we are parsing. A call to TclCopyAndCollapse() is
		 * needed to produce the element value. Inform the caller.
		 */

		literal = false;
	    }
	    TclParseBackslash(p, limit - p, &numChars, NULL);
	    p += (numChars - 1);
	    break;

	    /*
	     * Double-quote: if element is in quotes then terminate it.
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclPrintfResult(interp,
			    "%s element in quotes followed by \"%.*s\" "
			    "instead of space", typeStr, (int) (p2-p), p);
		    TclSetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK");







|







717
718
719
720
721
722
723
724
725
726
727
728
729
730
731

		/*
		 * Garbage after the closing quote; return an error.
		 */

		if (interp != NULL) {
		    p2 = p;
		    while ((p2 < limit) && !TclIsSpaceProcM(*p2)
			    && (p2 < p+20)) {
			p2++;
		    }
		    TclPrintfResult(interp,
			    "%s element in quotes followed by \"%.*s\" "
			    "instead of space", typeStr, (int) (p2-p), p);
		    TclSetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK");
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }

  done:
    while ((p < limit) && (TclIsSpaceProcM(*p))) {
	p++;
    }
    *elementPtr = elemStart;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }







|







769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
	    }
	    return TCL_ERROR;
	}
	size = (p - elemStart);
    }

  done:
    while ((p < limit) && TclIsSpaceProcM(*p)) {
	p++;
    }
    *elementPtr = elemStart;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
    const char *src,		/* String to convert to Tcl list element. */
    Tcl_Size length,		/* Number of bytes in src, or TCL_INDEX_NONE. */
    char *flagPtr)		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    const char *p = src;
    Tcl_Size nestingLevel = 0;	/* Brace nesting count */
    int forbidNone = 0;		/* Do not permit CONVERT_NONE mode. Something
				 * needs protection or escape. */
    int requireEscape = 0;	/* Force use of CONVERT_ESCAPE mode.  For some
				 * reason bare or brace-quoted form fails. */
    Tcl_Size extra = 0;		/* Count of number of extra bytes needed for
				 * formatted element, assuming we use escape
				 * sequences in formatting. */
    Tcl_Size bytesNeeded;	/* Buffer length computed to complete the
				 * element formatting in the selected mode. */
#if COMPAT
    int preferEscape = 0;	/* Use preferences to track whether to use */
    int preferBrace = 0;	/* CONVERT_MASK mode. */
    int braceCount = 0;		/* Count of all braces '{' '}' seen. */
#endif /* COMPAT */

    if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) {
	/*
	 * Empty string element must be brace quoted.
	 */







|

|







|
|







1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
    const char *src,		/* String to convert to Tcl list element. */
    Tcl_Size length,		/* Number of bytes in src, or TCL_INDEX_NONE. */
    char *flagPtr)		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    const char *p = src;
    Tcl_Size nestingLevel = 0;	/* Brace nesting count */
    bool forbidNone = false;	/* Do not permit CONVERT_NONE mode. Something
				 * needs protection or escape. */
    bool requireEscape = false;	/* Force use of CONVERT_ESCAPE mode.  For some
				 * reason bare or brace-quoted form fails. */
    Tcl_Size extra = 0;		/* Count of number of extra bytes needed for
				 * formatted element, assuming we use escape
				 * sequences in formatting. */
    Tcl_Size bytesNeeded;	/* Buffer length computed to complete the
				 * element formatting in the selected mode. */
#if COMPAT
    bool preferEscape = false;	/* Use preferences to track whether to use */
    bool preferBrace = false;	/* CONVERT_MASK mode. */
    int braceCount = 0;		/* Count of all braces '{' '}' seen. */
#endif /* COMPAT */

    if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) {
	/*
	 * Empty string element must be brace quoted.
	 */
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
     *			{#{a"b}}
     * and not like this:
     *			\#{a\"b}
     * This is inconsistent with [list x{a"b}], but we will not change that now.
     * Set that preference here so that we compute a tight size requirement.
     */
    if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
	preferBrace = 1;
    }
#endif

    if ((*p == '{') || (*p == '"')) {
	/*
	 * Must escape or protect so leading character of value is not
	 * misinterpreted as list element delimiting syntax.
	 */

	forbidNone = 1;
#if COMPAT
	preferBrace = 1;
#endif /* COMPAT */
    }

    while (length) {
	if (CHAR_TYPE(*p) != TYPE_NORMAL) {
	    switch (*p) {
	    case '{':	/* TYPE_BRACE */







|









|

|







1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
     *			{#{a"b}}
     * and not like this:
     *			\#{a\"b}
     * This is inconsistent with [list x{a"b}], but we will not change that now.
     * Set that preference here so that we compute a tight size requirement.
     */
    if ((*src == '#') && !(*flagPtr & DONT_QUOTE_HASH)) {
	preferBrace = true;
    }
#endif

    if ((*p == '{') || (*p == '"')) {
	/*
	 * Must escape or protect so leading character of value is not
	 * misinterpreted as list element delimiting syntax.
	 */

	forbidNone = true;
#if COMPAT
	preferBrace = true;
#endif /* COMPAT */
    }

    while (length) {
	if (CHAR_TYPE(*p) != TYPE_NORMAL) {
	    switch (*p) {
	    case '{':	/* TYPE_BRACE */
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
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
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
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
#endif /* COMPAT */
		extra++;			/* Escape '}' => '\}' */
		if (nestingLevel-- < 1) {
		    /*
		     * Unbalanced braces!  Cannot format with brace quoting.
		     */

		    requireEscape = 1;
		}
		break;
	    case ']':	/* TYPE_CLOSE_BRACK */
	    case '"':	/* TYPE_SPACE */
#if COMPAT
		forbidNone = 1;
		extra++;	/* Escapes all just prepend a backslash */
		preferEscape = 1;
		break;
#else
		TCL_FALLTHROUGH();
#endif /* COMPAT */
	    case '[':	/* TYPE_SUBS */
	    case '$':	/* TYPE_SUBS */
	    case ';':	/* TYPE_COMMAND_END */
		forbidNone = 1;
		extra++;	/* Escape sequences all one byte longer. */
#if COMPAT
		preferBrace = 1;
#endif /* COMPAT */
		break;
	    case '\\':	/* TYPE_SUBS */
		extra++;			/* Escape '\' => '\\' */
		if ((length == 1) ||
			((length == TCL_INDEX_NONE) && (p[1] == '\0'))) {
		    /*
		     * Final backslash. Cannot format with brace quoting.
		     */

		    requireEscape = 1;
		    break;
		}
		if (p[1] == '\n') {
		    extra++;	/* Escape newline => '\n', one byte longer */

		    /*
		     * Backslash newline sequence.  Brace quoting not permitted.
		     */

		    requireEscape = 1;
		    length -= (length > 0);
		    p++;
		    break;
		}
		if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
		    extra++;	/* Escape sequences all one byte longer. */
		    length -= (length > 0);
		    p++;
		}
		forbidNone = 1;
#if COMPAT
		preferBrace = 1;
#endif /* COMPAT */
		break;
	    case '\0':	/* TYPE_SUBS */
		if (length == TCL_INDEX_NONE) {
		    goto endOfString;
		}
		/* TODO: Panic on improper encoding? */
		break;
	    default:
		if (TclIsSpaceProcM(*p)) {
		    forbidNone = 1;
		    extra++;	/* Escape sequences all one byte longer. */
#if COMPAT
		    preferBrace = 1;
#endif
		}
		break;
	    }
	}
	length -= (length > 0);
	p++;
    }

  endOfString:
    if (nestingLevel > 0) {
	/*
	 * Unbalanced braces!  Cannot format with brace quoting.
	 */

	requireEscape = 1;
    }

    /*
     * We need at least as many bytes as are in the element value...
     */

    bytesNeeded = p - src;







|





|

|







|


|










|









|









|

|










|


|















|







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
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
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
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
#endif /* COMPAT */
		extra++;			/* Escape '}' => '\}' */
		if (nestingLevel-- < 1) {
		    /*
		     * Unbalanced braces!  Cannot format with brace quoting.
		     */

		    requireEscape = true;
		}
		break;
	    case ']':	/* TYPE_CLOSE_BRACK */
	    case '"':	/* TYPE_SPACE */
#if COMPAT
		forbidNone = true;
		extra++;	/* Escapes all just prepend a backslash */
		preferEscape = true;
		break;
#else
		TCL_FALLTHROUGH();
#endif /* COMPAT */
	    case '[':	/* TYPE_SUBS */
	    case '$':	/* TYPE_SUBS */
	    case ';':	/* TYPE_COMMAND_END */
		forbidNone = true;
		extra++;	/* Escape sequences all one byte longer. */
#if COMPAT
		preferBrace = true;
#endif /* COMPAT */
		break;
	    case '\\':	/* TYPE_SUBS */
		extra++;			/* Escape '\' => '\\' */
		if ((length == 1) ||
			((length == TCL_INDEX_NONE) && (p[1] == '\0'))) {
		    /*
		     * Final backslash. Cannot format with brace quoting.
		     */

		    requireEscape = true;
		    break;
		}
		if (p[1] == '\n') {
		    extra++;	/* Escape newline => '\n', one byte longer */

		    /*
		     * Backslash newline sequence.  Brace quoting not permitted.
		     */

		    requireEscape = true;
		    length -= (length > 0);
		    p++;
		    break;
		}
		if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) {
		    extra++;	/* Escape sequences all one byte longer. */
		    length -= (length > 0);
		    p++;
		}
		forbidNone = true;
#if COMPAT
		preferBrace = true;
#endif /* COMPAT */
		break;
	    case '\0':	/* TYPE_SUBS */
		if (length == TCL_INDEX_NONE) {
		    goto endOfString;
		}
		/* TODO: Panic on improper encoding? */
		break;
	    default:
		if (TclIsSpaceProcM(*p)) {
		    forbidNone = true;
		    extra++;	/* Escape sequences all one byte longer. */
#if COMPAT
		    preferBrace = true;
#endif
		}
		break;
	    }
	}
	length -= (length > 0);
	p++;
    }

  endOfString:
    if (nestingLevel > 0) {
	/*
	 * Unbalanced braces!  Cannot format with brace quoting.
	 */

	requireEscape = true;
    }

    /*
     * We need at least as many bytes as are in the element value...
     */

    bytesNeeded = p - src;
1880
1881
1882
1883
1884
1885
1886
1887

1888
1889
1890
1891
1892
1893
1894
#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1)

char *
Tcl_Concat(
    Tcl_Size argc,		/* Number of strings to concatenate. */
    const char *const *argv)	/* Array of strings to concatenate. */
{
    Tcl_Size i, needSpace = 0, bytesNeeded = 0;

    char *result, *p;

    /*
     * Dispose of the empty result corner case first to simplify later code.
     */

    if (argc == 0) {







|
>







1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1)

char *
Tcl_Concat(
    Tcl_Size argc,		/* Number of strings to concatenate. */
    const char *const *argv)	/* Array of strings to concatenate. */
{
    Tcl_Size i, bytesNeeded = 0;
    bool needSpace = false;
    char *result, *p;

    /*
     * Dispose of the empty result corner case first to simplify later code.
     */

    if (argc == 0) {
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
	 */

	if (needSpace) {
	    *p++ = ' ';
	}
	memcpy(p, element, elemLength);
	p += elemLength;
	needSpace = 1;
    }
    *p = '\0';
    return result;
}

/*
 *----------------------------------------------------------------------







|







1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
	 */

	if (needSpace) {
	    *p++ = ' ';
	}
	memcpy(p, element, elemLength);
	p += elemLength;
	needSpace = true;
    }
    *p = '\0';
    return result;
}

/*
 *----------------------------------------------------------------------
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
 */

Tcl_Obj *
Tcl_ConcatObj(
    Tcl_Size objc,		/* Number of objects to concatenate. */
    Tcl_Obj *const objv[])	/* Array of objects to concatenate. */
{
    int needSpace = 0;
    Tcl_Size i, bytesNeeded = 0, elemLength;
    const char *element;
    Tcl_Obj *objPtr, *resPtr;

    /*
     * Check first to see if all the items are of list type or empty. If so,
     * we will concat them together as lists, and return a list object. This







|







1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
 */

Tcl_Obj *
Tcl_ConcatObj(
    Tcl_Size objc,		/* Number of objects to concatenate. */
    Tcl_Obj *const objv[])	/* Array of objects to concatenate. */
{
    bool needSpace = false;
    Tcl_Size i, bytesNeeded = 0, elemLength;
    const char *element;
    Tcl_Obj *objPtr, *resPtr;

    /*
     * Check first to see if all the items are of list type or empty. If so,
     * we will concat them together as lists, and return a list object. This
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
	 * Append to the result with space if needed.
	 */

	if (needSpace) {
	    Tcl_AppendToObj(resPtr, " ", 1);
	}
	Tcl_AppendToObj(resPtr, element, elemLength);
	needSpace = 1;
    }
    return resPtr;
}

/*
 *----------------------------------------------------------------------
 *







|







2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
	 * Append to the result with space if needed.
	 */

	if (needSpace) {
	    Tcl_AppendToObj(resPtr, " ", 1);
	}
	Tcl_AppendToObj(resPtr, element, elemLength);
	needSpace = true;
    }
    return resPtr;
}

/*
 *----------------------------------------------------------------------
 *
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
	 * of the string, we failed.
	 */

	if (p == '\0') {
	    return (*str == '\0');
	}
	if ((*str == '\0') && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by calling ourselves recursively for each
	 * postfix of string, until either we match or we reach the end of the
	 * string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*');
	    p = *pattern;
	    if (p == '\0') {
		return 1;
	    }

	    /*
	     * This is a special case optimization for single-byte utf.
	     */

	    if (UCHAR(*pattern) < 0x80) {







|

















|







2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
	 * of the string, we failed.
	 */

	if (p == '\0') {
	    return (*str == '\0');
	}
	if ((*str == '\0') && (p != '*')) {
	    return false;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by calling ourselves recursively for each
	 * postfix of string, until either we match or we reach the end of the
	 * string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern
	     */

	    while (*(++pattern) == '*');
	    p = *pattern;
	    if (p == '\0') {
		return true;
	    }

	    /*
	     * This is a special case optimization for single-byte utf.
	     */

	    if (UCHAR(*pattern) < 0x80) {
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
				break;
			    }
			    str += charLen;
			}
		    }
		}
		if (Tcl_StringCaseMatch(str, pattern, nocase)) {
		    return 1;
		}
		if (*str == '\0') {
		    return 0;
		}
		str += TclUtfToUniChar(str, &ch1);
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any







|


|







2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
				break;
			    }
			    str += charLen;
			}
		    }
		}
		if (Tcl_StringCaseMatch(str, pattern, nocase)) {
		    return true;
		}
		if (*str == '\0') {
		    return false;
		}
		str += TclUtfToUniChar(str, &ch1);
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
		str += TclUtfToUniChar(str, &ch1);
		if (nocase) {
		    ch1 = Tcl_UniCharToLower(ch1);
		}
	    }
	    while (1) {
		if ((*pattern == ']') || (*pattern == '\0')) {
		    return 0;
		}
		if (UCHAR(*pattern) < 0x80) {
		    startChar = (int) (nocase
			    ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
		    pattern++;
		} else {
		    pattern += TclUtfToUniChar(pattern, &startChar);
		    if (nocase) {
			startChar = Tcl_UniCharToLower(startChar);
		    }
		}
		if (*pattern == '-') {
		    pattern++;
		    if (*pattern == '\0') {
			return 0;
		    }
		    if (UCHAR(*pattern) < 0x80) {
			endChar = (int) (nocase
				? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
			pattern++;
		    } else {
			pattern += TclUtfToUniChar(pattern, &endChar);







|














|







2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
		str += TclUtfToUniChar(str, &ch1);
		if (nocase) {
		    ch1 = Tcl_UniCharToLower(ch1);
		}
	    }
	    while (1) {
		if ((*pattern == ']') || (*pattern == '\0')) {
		    return false;
		}
		if (UCHAR(*pattern) < 0x80) {
		    startChar = (int) (nocase
			    ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
		    pattern++;
		} else {
		    pattern += TclUtfToUniChar(pattern, &startChar);
		    if (nocase) {
			startChar = Tcl_UniCharToLower(startChar);
		    }
		}
		if (*pattern == '-') {
		    pattern++;
		    if (*pattern == '\0') {
			return false;
		    }
		    if (UCHAR(*pattern) < 0x80) {
			endChar = (int) (nocase
				? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
			pattern++;
		    } else {
			pattern += TclUtfToUniChar(pattern, &endChar);
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359

2360
2361
2362
2363
2364
2365
2366
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    pattern++;
	    if (*pattern == '\0') {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	str += TclUtfToUniChar(str, &ch1);
	pattern += TclUtfToUniChar(pattern, &ch2);
	if (nocase) {
	    if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
		return 0;
	    }
	} else if (ch1 != ch2) {
	    return 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclByteArrayMatch --
 *
 *	See if a particular string matches a particular pattern.  Does not
 *	allow for case insensitivity.
 *	Parallels tclUtf.c:TclUniCharMatch, adjusted for char* and sans nocase.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and 0 otherwise. The
 *	matching operation permits the following special characters in the
 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int

TclByteArrayMatch(
    const unsigned char *string,/* String. */
    Tcl_Size strLen,		/* Length of String */
    const unsigned char *pattern,
				/* Pattern, which may contain special
				 * characters. */
    Tcl_Size ptnLen,		/* Length of Pattern */







|












|


|














|
|








<
>







2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359

2360
2361
2362
2363
2364
2365
2366
2367
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    pattern++;
	    if (*pattern == '\0') {
		return false;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	str += TclUtfToUniChar(str, &ch1);
	pattern += TclUtfToUniChar(pattern, &ch2);
	if (nocase) {
	    if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
		return false;
	    }
	} else if (ch1 != ch2) {
	    return false;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclByteArrayMatch --
 *
 *	See if a particular string matches a particular pattern.  Does not
 *	allow for case insensitivity.
 *	Parallels tclUtf.c:TclUniCharMatch, adjusted for char* and sans nocase.
 *
 * Results:
 *	The return value is true if string matches pattern, and false otherwise.
 *	The matching operation permits the following special characters in the
 *	pattern: *?\[] (see the manual entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */


bool
TclByteArrayMatch(
    const unsigned char *string,/* String. */
    Tcl_Size strLen,		/* Length of String */
    const unsigned char *pattern,
				/* Pattern, which may contain special
				 * characters. */
    Tcl_Size ptnLen,		/* Length of Pattern */
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return 0;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern.
	     */

	    while ((++pattern < patternEnd) && (*pattern == '*')) {
		/* empty body */
	    }
	    if (pattern == patternEnd) {
		return 1;
	    }
	    p = *pattern;
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character.
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    while ((string < stringEnd) && (p != *string)) {
			string++;
		    }
		}
		if (TclByteArrayMatch(string, stringEnd - string,
			pattern, patternEnd - pattern, 0)) {
		    return 1;
		}
		if (string == stringEnd) {
		    return 0;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any







|



















|
















|


|







2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
	 */

	if (pattern == patternEnd) {
	    return (string == stringEnd);
	}
	p = *pattern;
	if ((string == stringEnd) && (p != '*')) {
	    return false;
	}

	/*
	 * Check for a "*" as the next pattern character. It matches any
	 * substring. We handle this by skipping all the characters up to the
	 * next matching one in the pattern, and then calling ourselves
	 * recursively for each postfix of string, until either we match or we
	 * reach the end of the string.
	 */

	if (p == '*') {
	    /*
	     * Skip all successive *'s in the pattern.
	     */

	    while ((++pattern < patternEnd) && (*pattern == '*')) {
		/* empty body */
	    }
	    if (pattern == patternEnd) {
		return true;
	    }
	    p = *pattern;
	    while (1) {
		/*
		 * Optimization for matching - cruise through the string
		 * quickly if the next char in the pattern isn't a special
		 * character.
		 */

		if ((p != '[') && (p != '?') && (p != '\\')) {
		    while ((string < stringEnd) && (p != *string)) {
			string++;
		    }
		}
		if (TclByteArrayMatch(string, stringEnd - string,
			pattern, patternEnd - pattern, 0)) {
		    return true;
		}
		if (string == stringEnd) {
		    return false;
		}
		string++;
	    }
	}

	/*
	 * Check for a "?" as the next pattern character. It matches any
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
	    unsigned char ch1, startChar, endChar;

	    pattern++;
	    ch1 = *string;
	    string++;
	    while (1) {
		if ((*pattern == ']') || (pattern == patternEnd)) {
		    return 0;
		}
		startChar = *pattern;
		pattern++;
		if (*pattern == '-') {
		    pattern++;
		    if (pattern == patternEnd) {
			return 0;
		    }
		    endChar = *pattern;
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
			 * Matches ranges of form [a-z] or [z-a].







|






|







2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
	    unsigned char ch1, startChar, endChar;

	    pattern++;
	    ch1 = *string;
	    string++;
	    while (1) {
		if ((*pattern == ']') || (pattern == patternEnd)) {
		    return false;
		}
		startChar = *pattern;
		pattern++;
		if (*pattern == '-') {
		    pattern++;
		    if (pattern == patternEnd) {
			return false;
		    }
		    endChar = *pattern;
		    pattern++;
		    if (((startChar <= ch1) && (ch1 <= endChar))
			    || ((endChar <= ch1) && (ch1 <= startChar))) {
			/*
			 * Matches ranges of form [a-z] or [z-a].
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return 0;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (*string != *pattern) {
	    return 0;
	}
	string++;
	pattern++;
    }
}

/*







|









|







2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
	/*
	 * If the next pattern character is '\', just strip off the '\' so we
	 * do exact matching on the character that follows.
	 */

	if (p == '\\') {
	    if (++pattern == patternEnd) {
		return false;
	    }
	}

	/*
	 * There's no special character. Just make sure that the next bytes of
	 * each string match.
	 */

	if (*string != *pattern) {
	    return false;
	}
	string++;
	pattern++;
    }
}

/*
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
    Tcl_DString *dsPtr,		/* Structure describing dynamic string. */
    const char *element)	/* String to append. Must be
				 * null-terminated. */
{
    char *dst = dsPtr->string + dsPtr->length;
    int needSpace = TclNeedSpace(dsPtr->string, dst);
    char flags = 0;
    int quoteHash = 1;
    Tcl_Size newSize;

    if (needSpace) {
	/*
	 * If we need a space to separate the new element from something
	 * already ending the string, we're not appending the first element
	 * of any list, so we need not quote any leading hash character.
	 */
	quoteHash = 0;
    } else {
	/*
	 * We don't need a space, maybe because there's some already there.
	 * Checking whether we might be appending a first element is a bit
	 * more involved.
	 *
	 * Backtrack over all whitespace.







|








|







2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
    Tcl_DString *dsPtr,		/* Structure describing dynamic string. */
    const char *element)	/* String to append. Must be
				 * null-terminated. */
{
    char *dst = dsPtr->string + dsPtr->length;
    int needSpace = TclNeedSpace(dsPtr->string, dst);
    char flags = 0;
    bool quoteHash = true;
    Tcl_Size newSize;

    if (needSpace) {
	/*
	 * If we need a space to separate the new element from something
	 * already ending the string, we're not appending the first element
	 * of any list, so we need not quote any leading hash character.
	 */
	quoteHash = false;
    } else {
	/*
	 * We don't need a space, maybe because there's some already there.
	 * Checking whether we might be appending a first element is a bit
	 * more involved.
	 *
	 * Backtrack over all whitespace.
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
     * A space is needed unless either:
     * (a) we're at the start of the string, or
     *
     * (NOTE: This check is now absorbed into the loop below.)
     *

    if (end == start) {
	return 0;
    }

     *
     */

    /*
     * (b) we're at the start of a nested list-element, quoted with an open







|







3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
     * A space is needed unless either:
     * (a) we're at the start of the string, or
     *
     * (NOTE: This check is now absorbed into the loop below.)
     *

    if (end == start) {
	return false;
    }

     *
     */

    /*
     * (b) we're at the start of a nested list-element, quoted with an open
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
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
     *	characters as meaningful list syntax, expanded Unicode spaces as
     *	element separators, for example.)
     *

    end = Tcl_UtfPrev(end, start);
    while (*end == '{') {
	if (end == start) {
	    return 0;
	}
	end = Tcl_UtfPrev(end, start);
    }

     *
     */

    while ((--end >= start) && (*end == '{')) {
    }
    if (end < start) {
	return 0;
    }

    /*
     * (c) the trailing character of the string is already a list-element
     *	   separator, Use the same testing routine as TclFindElement to
     *	   enforce consistency.
     */

    if (TclIsSpaceProcM(*end)) {
	int result = 0;

	/*
	 * Trailing whitespace might be part of a backslash escape
	 * sequence. Handle that possibility.
	 */

	while ((--end >= start) && (*end == '\\')) {
	    result = !result;
	}
	return result;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *







|










|









|











|







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
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
     *	characters as meaningful list syntax, expanded Unicode spaces as
     *	element separators, for example.)
     *

    end = Tcl_UtfPrev(end, start);
    while (*end == '{') {
	if (end == start) {
	    return false;
	}
	end = Tcl_UtfPrev(end, start);
    }

     *
     */

    while ((--end >= start) && (*end == '{')) {
    }
    if (end < start) {
	return false;
    }

    /*
     * (c) the trailing character of the string is already a list-element
     *	   separator, Use the same testing routine as TclFindElement to
     *	   enforce consistency.
     */

    if (TclIsSpaceProcM(*end)) {
	bool result = false;

	/*
	 * Trailing whitespace might be part of a backslash escape
	 * sequence. Handle that possibility.
	 */

	while ((--end >= start) && (*end == '\\')) {
	    result = !result;
	}
	return result;
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410

4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424

int
TclReToGlob(
    Tcl_Interp *interp,
    const char *reStr,
    Tcl_Size reStrLen,
    Tcl_DString *dsPtr,
    int *exactPtr,
    int *quantifiersFoundPtr)
{
    int anchorLeft, anchorRight, lastIsStar, numStars;

    char *dsStr, *dsStrStart;
    const char *msg, *strEnd, *code;

    strEnd = reStr + reStrLen;
    Tcl_DStringInit(dsPtr);
    if (quantifiersFoundPtr != NULL) {
	*quantifiersFoundPtr = 0;
    }

    /*
     * "***=xxx" == "*xxx*", watch for glob-sensitive chars.
     */

    if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {







|
|

|
>






|







4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426

int
TclReToGlob(
    Tcl_Interp *interp,
    const char *reStr,
    Tcl_Size reStrLen,
    Tcl_DString *dsPtr,
    bool *exactPtr,
    bool *quantifiersFoundPtr)
{
    bool anchorLeft, anchorRight, lastIsStar;
    int numStars;
    char *dsStr, *dsStrStart;
    const char *msg, *strEnd, *code;

    strEnd = reStr + reStrLen;
    Tcl_DStringInit(dsPtr);
    if (quantifiersFoundPtr != NULL) {
	*quantifiersFoundPtr = false;
    }

    /*
     * "***=xxx" == "*xxx*", watch for glob-sensitive chars.
     */

    if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
		*dsStr++ = *p;
		break;
	    }
	}
	*dsStr++ = '*';
	Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
	if (exactPtr) {
	    *exactPtr = 0;
	}
	return TCL_OK;
    }

    /*
     * At most, the glob pattern has length reStrLen + 2 to account for
     * possible * at each end.







|







4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
		*dsStr++ = *p;
		break;
	    }
	}
	*dsStr++ = '*';
	Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart);
	if (exactPtr) {
	    *exactPtr = false;
	}
	return TCL_OK;
    }

    /*
     * At most, the glob pattern has length reStrLen + 2 to account for
     * possible * at each end.
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
     * Keep track of the last char being an unescaped star to prevent multiple
     * instances.  Simpler than checking that the last star may be escaped.
     */

    msg = NULL;
    code = NULL;
    const char *p = reStr;
    anchorRight = 0;
    lastIsStar = 0;
    numStars = 0;

    if (*p == '^') {
	anchorLeft = 1;
	p++;
    } else {
	anchorLeft = 0;
	*dsStr++ = '*';
	lastIsStar = 1;
    }

    for ( ; p < strEnd; p++) {
	switch (*p) {
	case '\\':
	    p++;
	    switch (*p) {







|
|
|


|


|

|







4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
     * Keep track of the last char being an unescaped star to prevent multiple
     * instances.  Simpler than checking that the last star may be escaped.
     */

    msg = NULL;
    code = NULL;
    const char *p = reStr;
    anchorRight = false;
    lastIsStar = false;
    numStars = false;

    if (*p == '^') {
	anchorLeft = true;
	p++;
    } else {
	anchorLeft = false;
	*dsStr++ = '*';
	lastIsStar = true;
    }

    for ( ; p < strEnd; p++) {
	switch (*p) {
	case '\\':
	    p++;
	    switch (*p) {
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
		break;
	    case 'v':
		*dsStr++ = '\v';
		break;
	    case 'B': case '\\':
		*dsStr++ = '\\';
		*dsStr++ = '\\';
		anchorLeft = 0; /* prevent exact match */
		break;
	    case '*': case '[': case ']': case '?':
		/* Only add \ where necessary for glob */
		*dsStr++ = '\\';
		anchorLeft = 0; /* prevent exact match */
		TCL_FALLTHROUGH();
	    case '{': case '}': case '(': case ')': case '+':
	    case '.': case '|': case '^': case '$':
		*dsStr++ = *p;
		break;
	    default:
		msg = "invalid escape sequence";
		code = "BADESCAPE";
		goto invalidGlob;
	    }
	    break;
	case '.':
	    if (quantifiersFoundPtr != NULL) {
		*quantifiersFoundPtr = 1;
	    }
	    anchorLeft = 0; /* prevent exact match */
	    if (p+1 < strEnd) {
		if (p[1] == '*') {
		    p++;
		    if (!lastIsStar) {
			*dsStr++ = '*';
			lastIsStar = 1;
			numStars++;
		    }
		    continue;
		} else if (p[1] == '+') {
		    p++;
		    *dsStr++ = '?';
		    *dsStr++ = '*';
		    lastIsStar = 1;
		    numStars++;
		    continue;
		}
	    }
	    *dsStr++ = '?';
	    break;
	case '$':
	    if (p+1 != strEnd) {
		msg = "$ not anchor";
		code = "NONANCHOR";
		goto invalidGlob;
	    }
	    anchorRight = 1;
	    break;
	case '*': case '+': case '?': case '|': case '^':
	case '{': case '}': case '(': case ')': case '[': case ']':
	    msg = "unhandled RE special char";
	    code = "UNHANDLED";
	    goto invalidGlob;
	default:
	    *dsStr++ = *p;
	    break;
	}
	lastIsStar = 0;
    }
    if (numStars > 1) {
	/*
	 * Heuristic: if >1 non-anchoring *, the risk is large that glob
	 * matching is slower than the RE engine, so report invalid.
	 */








|




|













|

|





|







|












|










|







4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
		break;
	    case 'v':
		*dsStr++ = '\v';
		break;
	    case 'B': case '\\':
		*dsStr++ = '\\';
		*dsStr++ = '\\';
		anchorLeft = false; /* prevent exact match */
		break;
	    case '*': case '[': case ']': case '?':
		/* Only add \ where necessary for glob */
		*dsStr++ = '\\';
		anchorLeft = false; /* prevent exact match */
		TCL_FALLTHROUGH();
	    case '{': case '}': case '(': case ')': case '+':
	    case '.': case '|': case '^': case '$':
		*dsStr++ = *p;
		break;
	    default:
		msg = "invalid escape sequence";
		code = "BADESCAPE";
		goto invalidGlob;
	    }
	    break;
	case '.':
	    if (quantifiersFoundPtr != NULL) {
		*quantifiersFoundPtr = true;
	    }
	    anchorLeft = false; /* prevent exact match */
	    if (p+1 < strEnd) {
		if (p[1] == '*') {
		    p++;
		    if (!lastIsStar) {
			*dsStr++ = '*';
			lastIsStar = true;
			numStars++;
		    }
		    continue;
		} else if (p[1] == '+') {
		    p++;
		    *dsStr++ = '?';
		    *dsStr++ = '*';
		    lastIsStar = true;
		    numStars++;
		    continue;
		}
	    }
	    *dsStr++ = '?';
	    break;
	case '$':
	    if (p+1 != strEnd) {
		msg = "$ not anchor";
		code = "NONANCHOR";
		goto invalidGlob;
	    }
	    anchorRight = true;
	    break;
	case '*': case '+': case '?': case '|': case '^':
	case '{': case '}': case '(': case ')': case '[': case ']':
	    msg = "unhandled RE special char";
	    code = "UNHANDLED";
	    goto invalidGlob;
	default:
	    *dsStr++ = *p;
	    break;
	}
	lastIsStar = false;
    }
    if (numStars > 1) {
	/*
	 * Heuristic: if >1 non-anchoring *, the risk is large that glob
	 * matching is slower than the RE engine, so report invalid.
	 */

Changes to generic/tclVar.c.
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
		part2Ptr = VarHashGetKey(varPtr);
	    }

	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	    TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
		    (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
			    | TCL_TRACE_UNSETS,
		    /* leaveErrMsg */ 0, index);

	    /*
	     * The traces that we just called may have triggered a change in
	     * the set of traces. If so, reload the traces to manipulate.
	     */

	    tracePtr = NULL;







|







2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
		part2Ptr = VarHashGetKey(varPtr);
	    }

	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	    TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
		    (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
			    | TCL_TRACE_UNSETS,
		    /*leaveErrMsg*/ false, index);

	    /*
	     * The traces that we just called may have triggered a change in
	     * the set of traces. If so, reload the traces to manipulate.
	     */

	    tracePtr = NULL;
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
	 * append step. We now append the arguments all at once because it's
	 * faster. Note that a read trace and a write trace for the variable
	 * will now each only be called once. Also, if the variable's old
	 * value is unshared we modify it directly, otherwise we create a new
	 * copy to modify: this is "copy on write".
	 */

	int createdNewObj = 0;

	/*
	 * Protect the variable pointers around the TclPtrGetVarIdx call
	 * to insure that they remain valid even if the variable was undefined
	 * and unused.
	 */








|







2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
	 * append step. We now append the arguments all at once because it's
	 * faster. Note that a read trace and a write trace for the variable
	 * will now each only be called once. Also, if the variable's old
	 * value is unshared we modify it directly, otherwise we create a new
	 * copy to modify: this is "copy on write".
	 */

	bool createdNewObj = false;

	/*
	 * Protect the variable pointers around the TclPtrGetVarIdx call
	 * to insure that they remain valid even if the variable was undefined
	 * and unused.
	 */

2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
	    /*
	     * We couldn't read the old value: either the var doesn't yet
	     * exist or it's an array element. If it's new, we will try to
	     * create it with Tcl_ObjSetVar2 below.
	     */

	    TclNewObj(varValuePtr);
	    createdNewObj = 1;
	} else if (Tcl_IsShared(varValuePtr)) {
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = 1;
	}

	Tcl_Size numElems;
	int result = TclListObjLength(interp, varValuePtr, &numElems);
	if (result == TCL_OK) {
	    result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
		    (objc-2), (objv+2));







|


|







2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
	    /*
	     * We couldn't read the old value: either the var doesn't yet
	     * exist or it's an array element. If it's new, we will try to
	     * create it with Tcl_ObjSetVar2 below.
	     */

	    TclNewObj(varValuePtr);
	    createdNewObj = true;
	} else if (Tcl_IsShared(varValuePtr)) {
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = true;
	}

	Tcl_Size numElems;
	int result = TclListObjLength(interp, varValuePtr, &numElems);
	if (result == TCL_OK) {
	    result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
		    (objc-2), (objv+2));
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
    int donerc = TCL_BREAK;

    if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
	donerc = TCL_ERROR;
	return donerc;
    }

    int gotValue = 0;
    while (1) {
	Tcl_HashEntry *hPtr = searchPtr->nextEntry;

	if (hPtr != NULL) {
	    searchPtr->nextEntry = NULL;
	} else {
	    hPtr = Tcl_NextHashEntry(&searchPtr->search);
	    if (hPtr == NULL) {
		gotValue = 0;
		break;
	    }
	}
	varPtr = VarHashGetValue(hPtr);
	if (!TclIsVarUndefined(varPtr)) {
	    gotValue = 1;
	    break;
	}
    }

    if (!gotValue) {
	return donerc;
    }







|








|





|







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
    int donerc = TCL_BREAK;

    if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
	donerc = TCL_ERROR;
	return donerc;
    }

    bool gotValue = false;
    while (1) {
	Tcl_HashEntry *hPtr = searchPtr->nextEntry;

	if (hPtr != NULL) {
	    searchPtr->nextEntry = NULL;
	} else {
	    hPtr = Tcl_NextHashEntry(&searchPtr->search);
	    if (hPtr == NULL) {
		gotValue = false;
		break;
	    }
	}
	varPtr = VarHashGetValue(hPtr);
	if (!TclIsVarUndefined(varPtr)) {
	    gotValue = true;
	    break;
	}
    }

    if (!gotValue) {
	return donerc;
    }
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
	     */

	    if (elPtr->flags & VAR_TRACED_UNSET) {
		Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);

		elPtr->flags &= ~VAR_TRACE_ACTIVE;
		TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
			elNamePtr, flags,/* leaveErrMsg */ 0, index);
	    }

	    Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
	    for (VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); tracePtr; ) {
		VarTrace *prevPtr = tracePtr;

		tracePtr = tracePtr->nextPtr;







|







5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
	     */

	    if (elPtr->flags & VAR_TRACED_UNSET) {
		Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);

		elPtr->flags &= ~VAR_TRACE_ACTIVE;
		TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
			elNamePtr, flags, /*leaveErrMsg*/ false, index);
	    }

	    Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
	    for (VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); tracePtr; ) {
		VarTrace *prevPtr = tracePtr;

		tracePtr = tracePtr->nextPtr;
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
    Interp *iPtr = (Interp *) interp;
    const char *varName, *pattern, *simplePattern;
    Tcl_HashSearch search;
    Var *varPtr;
    Namespace *nsPtr;
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr;
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    Tcl_Obj *simplePatternPtr = NULL;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * variables. We only use this effective namespace if there's no active
     * Tcl procedure frame.
     */

    if (objc == 1) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 2) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no variables there can be found.







|











|







5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
    Interp *iPtr = (Interp *) interp;
    const char *varName, *pattern, *simplePattern;
    Tcl_HashSearch search;
    Var *varPtr;
    Namespace *nsPtr;
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr;
    bool specificNsInPattern = false;/* Init. to avoid compiler warning. */
    Tcl_Obj *simplePatternPtr = NULL;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * variables. We only use this effective namespace if there's no active
     * Tcl procedure frame.
     */

    if (objc == 1) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = false;
    } else if (objc == 2) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no variables there can be found.
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    const char *pattern, *simplePattern;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
    Tcl_Obj *simplePatternPtr = NULL;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * variables. We only use this effective namespace if there's no active
     * Tcl procedure frame.
     */

    if (objc == 1) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 2) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no variables there can be found.







|











|







6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    const char *pattern, *simplePattern;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
    bool specificNsInPattern = false;/* Init. to avoid compiler warning. */
    Tcl_Obj *simplePatternPtr = NULL;

    /*
     * Get the pattern and find the "effective namespace" in which to list
     * variables. We only use this effective namespace if there's no active
     * Tcl procedure frame.
     */

    if (objc == 1) {
	simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = false;
    } else if (objc == 2) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an error
	 * was found while parsing the pattern, return it. Otherwise, if the
	 * namespace wasn't found, just leave nsPtr NULL: we will return an
	 * empty list since no variables there can be found.
Changes to generic/tclZipfs.c.
140
141
142
143
144
145
146

147
148
149
150
151
152
153
    uint16_t pathLen;
    uint16_t extraLen;
};
#endif
#define ZIP_LOCAL_HEADER_SIG		0x04034b50

enum ZipLocalFlags {

    ZIP_LOCAL_FLAGS_UTF8 = 0x0800
};

/*
 * Central header of ZIP archive member at end of ZIP file.
 * C can't express this structure type even close to portably (thanks for
 * nothing, Clang and MSVC).







>







140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
    uint16_t pathLen;
    uint16_t extraLen;
};
#endif
#define ZIP_LOCAL_HEADER_SIG		0x04034b50

enum ZipLocalFlags {
    ZIP_LOCAL_FLAGS_ENC = 0x0001,
    ZIP_LOCAL_FLAGS_UTF8 = 0x0800
};

/*
 * Central header of ZIP archive member at end of ZIP file.
 * C can't express this structure type even close to portably (thanks for
 * nothing, Clang and MSVC).
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
/*
 * In-core description of mounted ZIP archive file.
 */

typedef struct ZipFile {
    char *name;			/* Archive name */
    size_t nameLength;		/* Length of archive name */
    char isMemBuffer;		/* When true, not a file but a memory buffer */
    Tcl_Channel chan;		/* Channel handle or NULL */
    unsigned char *data;	/* Memory mapped or malloc'ed file */
    size_t length;		/* Length of memory mapped file */
    void *ptrToFree;		/* Non-NULL if malloc'ed file */
    size_t numFiles;		/* Number of files in archive */
    size_t baseOffset;		/* Archive start */
    size_t passOffset;		/* Password start */







|







261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
/*
 * In-core description of mounted ZIP archive file.
 */

typedef struct ZipFile {
    char *name;			/* Archive name */
    size_t nameLength;		/* Length of archive name */
    bool isMemBuffer;		/* When true, not a file but a memory buffer */
    Tcl_Channel chan;		/* Channel handle or NULL */
    unsigned char *data;	/* Memory mapped or malloc'ed file */
    size_t length;		/* Length of memory mapped file */
    void *ptrToFree;		/* Non-NULL if malloc'ed file */
    size_t numFiles;		/* Number of files in archive */
    size_t baseOffset;		/* Archive start */
    size_t passOffset;		/* Password start */
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
    int numCompressedBytes;	/* Compressed size of the virtual file.
				 * -1 for zip64 */
    int compressMethod;		/* Compress method */
    int isDirectory;		/* 0 if file, 1 if directory, -1 if root */
    int depth;			/* Number of slashes in path. */
    int crc32;			/* CRC-32 as stored in ZIP */
    int timestamp;		/* Modification time */
    int isEncrypted;		/* True if data is encrypted */
    int flags;			/* See ZipEntryFlags for bit definitions. */
    unsigned char *data;	/* File data if written */
    struct ZipEntry *next;	/* Next file in the same archive */
    struct ZipEntry *tnext;	/* Next top-level dir in archive */
} ZipEntry;

enum ZipEntryFlags {







|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
    int numCompressedBytes;	/* Compressed size of the virtual file.
				 * -1 for zip64 */
    int compressMethod;		/* Compress method */
    int isDirectory;		/* 0 if file, 1 if directory, -1 if root */
    int depth;			/* Number of slashes in path. */
    int crc32;			/* CRC-32 as stored in ZIP */
    int timestamp;		/* Modification time */
    bool isEncrypted;		/* True if data is encrypted */
    int flags;			/* See ZipEntryFlags for bit definitions. */
    unsigned char *data;	/* File data if written */
    struct ZipEntry *next;	/* Next file in the same archive */
    struct ZipEntry *tnext;	/* Next top-level dir in archive */
} ZipEntry;

enum ZipEntryFlags {
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
    Tcl_Size numBytes;		/* Number of bytes of uncompressed data */
    Tcl_Size cursor;		/* Seek position for next read or write*/
    unsigned char *ubuf;	/* Pointer to the uncompressed data */
    unsigned char *ubufToFree;	/* NULL if ubuf points to memory that does not
				 * need freeing. Else memory to free (ubuf
				 * may point *inside* the block) */
    Tcl_Size ubufSize;		/* Size of allocated ubufToFree */
    int iscompr;		/* True if data is compressed */
    int isDirectory;		/* Set to 1 if directory, or -1 if root */
    int isEncrypted;		/* True if data is encrypted */
    int mode;			/* O_WRITE, O_APPEND, O_TRUNC etc.*/
    unsigned long keys[3];	/* Key for decryption */
} ZipChannel;

static inline int
ZipChannelWritable(
    ZipChannel *info)







|

|







338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
    Tcl_Size numBytes;		/* Number of bytes of uncompressed data */
    Tcl_Size cursor;		/* Seek position for next read or write*/
    unsigned char *ubuf;	/* Pointer to the uncompressed data */
    unsigned char *ubufToFree;	/* NULL if ubuf points to memory that does not
				 * need freeing. Else memory to free (ubuf
				 * may point *inside* the block) */
    Tcl_Size ubufSize;		/* Size of allocated ubufToFree */
    bool isCompressed;		/* True if data is compressed */
    int isDirectory;		/* Set to 1 if directory, or -1 if root */
    bool isEncrypted;		/* True if data is encrypted */
    int mode;			/* O_WRITE, O_APPEND, O_TRUNC etc.*/
    unsigned long keys[3];	/* Key for decryption */
} ZipChannel;

static inline int
ZipChannelWritable(
    ZipChannel *info)
365
366
367
368
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
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
 * archive members in all mounted ZIP archives.
 *
 * The "zipHash" components is the process wide global table of all mounted
 * ZIP archive files.
 */

static struct {
    int initialized;		/* True when initialized */
    int lock;			/* RW lock, see below */
    int waiters;		/* RW lock, see below */
    int wrmax;			/* Maximum write size of a file; only written
				 * to from Tcl code in a trusted interpreter,
				 * so NOT protected by mutex. */
    char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when
				 * they are believed to not be UTF-8; only
				 * written to from Tcl code in a trusted
				 * interpreter, so not protected by mutex. */
    int idCount;		/* Counter for channel names */
    Tcl_HashTable fileHash;	/* File name to ZipEntry mapping */
    Tcl_HashTable zipHash;	/* Mount to ZipFile mapping */
} ZipFS = {
    0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, 0,
	    {0,{0,0,0,0},0,0,0,0,0,0,0,0,0},
	    {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}
};

/*
 * For password rotation.
 */

static const char pwrot[17] =
    "\x00\x80\x40\xC0\x20\xA0\x60\xE0"
    "\x10\x90\x50\xD0\x30\xB0\x70\xF0";

static int zipfs_tcl_library_init = 0;
static const char *zipfs_literal_tcl_library = NULL;

/* Function prototypes */

static int		CopyImageFile(Tcl_Interp *interp, const char *imgName,
			    Tcl_Channel out);
static int		DescribeMounted(Tcl_Interp *interp,
			    const char *mountPoint);
static int		InitReadableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z);
static int		InitWritableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z, int trunc);
static int		ListMountPoints(Tcl_Interp *interp);
static int		ContainsMountPoint(const char *path, int pathLen);
static void		CleanupMount(ZipFile *zf);
static Tcl_Obj *	ScriptLibrarySetup(const char *dirName);
static void		SerializeCentralDirectoryEntry(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    ZipEntry *z, size_t nameLength,
			    long long dataStartOffset);
static void		SerializeCentralDirectorySuffix(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    int entryCount, long long dataStartOffset,
			    long long directoryStartOffset,
			    long long suffixStartOffset);
static void		SerializeLocalEntryHeader(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    ZipEntry *z, int nameLength, int align);
static int		IsCryptHeaderValid(ZipEntry *z,
			    unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
static int		DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z,
			    unsigned long keys[3],
			    unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
#if !defined(STATIC_BUILD)
static int		ZipfsAppHookFindTclInit(const char *archive);
#endif







|













|












|













|

















|







366
367
368
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
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
 * archive members in all mounted ZIP archives.
 *
 * The "zipHash" components is the process wide global table of all mounted
 * ZIP archive files.
 */

static struct {
    bool initialized;		/* True when initialized */
    int lock;			/* RW lock, see below */
    int waiters;		/* RW lock, see below */
    int wrmax;			/* Maximum write size of a file; only written
				 * to from Tcl code in a trusted interpreter,
				 * so NOT protected by mutex. */
    char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when
				 * they are believed to not be UTF-8; only
				 * written to from Tcl code in a trusted
				 * interpreter, so not protected by mutex. */
    int idCount;		/* Counter for channel names */
    Tcl_HashTable fileHash;	/* File name to ZipEntry mapping */
    Tcl_HashTable zipHash;	/* Mount to ZipFile mapping */
} ZipFS = {
    false, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, 0,
	    {0,{0,0,0,0},0,0,0,0,0,0,0,0,0},
	    {0,{0,0,0,0},0,0,0,0,0,0,0,0,0}
};

/*
 * For password rotation.
 */

static const char pwrot[17] =
    "\x00\x80\x40\xC0\x20\xA0\x60\xE0"
    "\x10\x90\x50\xD0\x30\xB0\x70\xF0";

static bool zipfs_tcl_library_init = false;
static const char *zipfs_literal_tcl_library = NULL;

/* Function prototypes */

static int		CopyImageFile(Tcl_Interp *interp, const char *imgName,
			    Tcl_Channel out);
static int		DescribeMounted(Tcl_Interp *interp,
			    const char *mountPoint);
static int		InitReadableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z);
static int		InitWritableChannel(Tcl_Interp *interp,
			    ZipChannel *info, ZipEntry *z, int trunc);
static int		ListMountPoints(Tcl_Interp *interp);
static bool		ContainsMountPoint(const char *path, int pathLen);
static void		CleanupMount(ZipFile *zf);
static Tcl_Obj *	ScriptLibrarySetup(const char *dirName);
static void		SerializeCentralDirectoryEntry(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    ZipEntry *z, size_t nameLength,
			    long long dataStartOffset);
static void		SerializeCentralDirectorySuffix(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    int entryCount, long long dataStartOffset,
			    long long directoryStartOffset,
			    long long suffixStartOffset);
static void		SerializeLocalEntryHeader(
			    const unsigned char *start,
			    const unsigned char *end, unsigned char *buf,
			    ZipEntry *z, int nameLength, int align);
static bool		IsCryptHeaderValid(ZipEntry *z,
			    unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
static int		DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z,
			    unsigned long keys[3],
			    unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
#if !defined(STATIC_BUILD)
static int		ZipfsAppHookFindTclInit(const char *archive);
#endif
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
880
 *    Returns 1 if the header is valid else 0.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static int
IsCryptHeaderValid(
    ZipEntry *z,
    unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN])
{
    /*
     * There are multiple possibilities. The last one or two bytes of the
     * encryption header should match the last one or two bytes of the
     * CRC of the file. Or the last byte of the encryption header should
     * be the high order byte of the file time. Depending on the archiver
     * and version, any of the might be in used. We follow libzip in checking
     * only one byte against both the crc and the time. Note that by design
     * the check generates high number of false positives in any case.
     * Also, in case a check is passed when it should not, the final CRC
     * calculation will (should) catch it. Only difference is it will be
     * reported as a corruption error instead of incorrect password.
     */
    int dosTime = ToDosTime(z->timestamp);
    if (cryptHeader[11] == (unsigned char)(dosTime >> 8)) {
	/* Infozip style - Tested with test-password.zip */
	return 1;
    }
    /* DOS time did not match, may be CRC does */
    if (z->crc32) {
	/* Pkware style - Tested with test-password2.zip */
	return (cryptHeader[11] == (unsigned char)(z->crc32 >> 24));
    }

    /* No CRC, no way to verify. Assume valid */
    return 1;
}

/*
 *------------------------------------------------------------------------
 *
 * DecodeCryptHeader --
 *







|



















|








|







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
880
881
 *    Returns 1 if the header is valid else 0.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static bool
IsCryptHeaderValid(
    ZipEntry *z,
    unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN])
{
    /*
     * There are multiple possibilities. The last one or two bytes of the
     * encryption header should match the last one or two bytes of the
     * CRC of the file. Or the last byte of the encryption header should
     * be the high order byte of the file time. Depending on the archiver
     * and version, any of the might be in used. We follow libzip in checking
     * only one byte against both the crc and the time. Note that by design
     * the check generates high number of false positives in any case.
     * Also, in case a check is passed when it should not, the final CRC
     * calculation will (should) catch it. Only difference is it will be
     * reported as a corruption error instead of incorrect password.
     */
    int dosTime = ToDosTime(z->timestamp);
    if (cryptHeader[11] == (unsigned char)(dosTime >> 8)) {
	/* Infozip style - Tested with test-password.zip */
	return true;
    }
    /* DOS time did not match, may be CRC does */
    if (z->crc32) {
	/* Pkware style - Tested with test-password2.zip */
	return (cryptHeader[11] == (unsigned char)(z->crc32 >> 24));
    }

    /* No CRC, no way to verify. Assume valid */
    return true;
}

/*
 *------------------------------------------------------------------------
 *
 * DecodeCryptHeader --
 *
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
 *    0 - otherwise
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static int
ContainsMountPoint(
    const char *path,
    int pathLen)
{
    if (ZipFS.zipHash.numEntries == 0) {
	return 0;
    }
    if (pathLen < 0) {
	pathLen = strlen(path);
    }

    /*
     * We are looking for the case where the path is //zipfs:/a/b







|





|







1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
 *    0 - otherwise
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
static bool
ContainsMountPoint(
    const char *path,
    int pathLen)
{
    if (ZipFS.zipHash.numEntries == 0) {
	return false;
    }
    if (pathLen < 0) {
	pathLen = strlen(path);
    }

    /*
     * We are looking for the case where the path is //zipfs:/a/b
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
	     */

	    for (const ZipEntry *z = zf->topEnts; z; z = z->tnext) {
		int lenz = (int) strlen(z->name);
		if ((lenz >= pathLen) &&
			(z->name[pathLen] == '/' || z->name[pathLen] == '\0') &&
			(strncmp(z->name, path, pathLen) == 0)) {
		    return 1;
		}
	    }
	} else if ((zf->mountPointLen >= pathLen)
		&& (zf->mountPoint[pathLen] == '/'
			|| zf->mountPoint[pathLen] == '\0'
			|| pathLen == ZIPFS_VOLUME_LEN)
		&& (strncmp(zf->mountPoint, path, pathLen) == 0)) {
	    /* Matched standard mount */
	    return 1;
	}
    }
    return 0;
}

/*
 *-------------------------------------------------------------------------
 *
 * AllocateZipFile, AllocateZipEntry, AllocateZipChannel --
 *







|








|


|







1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
	     */

	    for (const ZipEntry *z = zf->topEnts; z; z = z->tnext) {
		int lenz = (int) strlen(z->name);
		if ((lenz >= pathLen) &&
			(z->name[pathLen] == '/' || z->name[pathLen] == '\0') &&
			(strncmp(z->name, path, pathLen) == 0)) {
		    return true;
		}
	    }
	} else if ((zf->mountPointLen >= pathLen)
		&& (zf->mountPoint[pathLen] == '/'
			|| zf->mountPoint[pathLen] == '\0'
			|| pathLen == ZIPFS_VOLUME_LEN)
		&& (strncmp(zf->mountPoint, path, pathLen) == 0)) {
	    /* Matched standard mount */
	    return true;
	}
    }
    return false;
}

/*
 *-------------------------------------------------------------------------
 *
 * AllocateZipFile, AllocateZipEntry, AllocateZipChannel --
 *
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
    int needZip,
    ZipFile *zf)
{
    size_t i;
    void *handle;

    zf->nameLength = 0;
    zf->isMemBuffer = 0;
#ifdef _WIN32
    zf->data = NULL;
    zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
    zf->data = (unsigned char *) MAP_FAILED;
#endif /* _WIN32 */
    zf->length = 0;







|







1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
    int needZip,
    ZipFile *zf)
{
    size_t i;
    void *handle;

    zf->nameLength = 0;
    zf->isMemBuffer = false;
#ifdef _WIN32
    zf->data = NULL;
    zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
    zf->data = (unsigned char *) MAP_FAILED;
#endif /* _WIN32 */
    zf->length = 0;
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
	if (isNew) {
	    z = AllocateZipEntry();
	    Tcl_SetHashValue(hPtr, z);

	    z->depth = CountSlashes(mountPoint);
	    assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
	    z->zipFilePtr = zf;
	    z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
	    z->offset = zf->baseOffset;
	    z->compressMethod = ZIP_COMPMETH_STORED;
	    z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
	    if (!strcmp(z->name, ZIPFS_VOLUME)) {
		z->flags |= ZE_F_VOLUME; /* Mark as root volume */
	    }
	    Tcl_Time t;
	    Tcl_GetTime(&t);
	    z->timestamp = t.sec;
	    z->next = zf->entries;
	    zf->entries = z;
	}
    }
    q = zf->data + zf->directoryOffset;
    Tcl_DStringInit(&fpBuf);
    for (size_t i = 0; i < zf->numFiles; i++) {
	const unsigned char *start = zf->data;
	const unsigned char *end = zf->data + zf->length;
	int isdir = 0;

	size_t pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS);
	size_t comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
	unsigned extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS);
	Tcl_DStringSetLength(&ds, 0);
	char *path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds);
	if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
	    Tcl_DStringSetLength(&ds, pathlen - 1);
	    path = Tcl_DStringValue(&ds);
	    isdir = 1;
	}
	if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
	    goto nextent;
	}
	unsigned char *lq = zf->data + zf->baseOffset
		+ ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
	if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) {







|


















|









|







1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
	if (isNew) {
	    z = AllocateZipEntry();
	    Tcl_SetHashValue(hPtr, z);

	    z->depth = CountSlashes(mountPoint);
	    assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
	    z->zipFilePtr = zf;
	    z->isDirectory = (zf->baseOffset == 0) ? true : -1; /* root marker */
	    z->offset = zf->baseOffset;
	    z->compressMethod = ZIP_COMPMETH_STORED;
	    z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
	    if (!strcmp(z->name, ZIPFS_VOLUME)) {
		z->flags |= ZE_F_VOLUME; /* Mark as root volume */
	    }
	    Tcl_Time t;
	    Tcl_GetTime(&t);
	    z->timestamp = t.sec;
	    z->next = zf->entries;
	    zf->entries = z;
	}
    }
    q = zf->data + zf->directoryOffset;
    Tcl_DStringInit(&fpBuf);
    for (size_t i = 0; i < zf->numFiles; i++) {
	const unsigned char *start = zf->data;
	const unsigned char *end = zf->data + zf->length;
	bool isdir = false;

	size_t pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS);
	size_t comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
	unsigned extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS);
	Tcl_DStringSetLength(&ds, 0);
	char *path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds);
	if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
	    Tcl_DStringSetLength(&ds, pathlen - 1);
	    path = Tcl_DStringValue(&ds);
	    isdir = true;
	}
	if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
	    goto nextent;
	}
	unsigned char *lq = zf->data + zf->baseOffset
		+ ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
	if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) {
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
	char *fullpath = MapPathToZipfs(interp, mountPoint, path, &fpBuf);
	z = AllocateZipEntry();
	z->depth = CountSlashes(fullpath);
	assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
	z->zipFilePtr = zf;
	z->isDirectory = isdir;
	z->isEncrypted =
		(ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
		&& (nbcompr > ZIP_CRYPT_HDR_LEN);
	z->offset = offs;
	int dosTime, dosDate;
	if (gq) {
	    z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS);
	    dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS);
	    dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS);







|







2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
	char *fullpath = MapPathToZipfs(interp, mountPoint, path, &fpBuf);
	z = AllocateZipEntry();
	z->depth = CountSlashes(fullpath);
	assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
	z->zipFilePtr = zf;
	z->isDirectory = isdir;
	z->isEncrypted =
		(ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & ZIP_LOCAL_FLAGS_ENC)
		&& (nbcompr > ZIP_CRYPT_HDR_LEN);
	z->offset = offs;
	int dosTime, dosDate;
	if (gq) {
	    z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS);
	    dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS);
	    dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS);
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
		    break;
		}

		ZipEntry *zd = AllocateZipEntry();
		zd->depth = CountSlashes(dir);
		assert(zd->depth > ZIPFS_ROOTDIR_DEPTH);
		zd->zipFilePtr = zf;
		zd->isDirectory = 1;
		zd->offset = z->offset;
		zd->timestamp = z->timestamp;
		zd->compressMethod = ZIP_COMPMETH_STORED;
		Tcl_SetHashValue(hPtr, zd);
		zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
		zd->next = zf->entries;
		zf->entries = zd;







|







2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
		    break;
		}

		ZipEntry *zd = AllocateZipEntry();
		zd->depth = CountSlashes(dir);
		assert(zd->depth > ZIPFS_ROOTDIR_DEPTH);
		zd->zipFilePtr = zf;
		zd->isDirectory = true;
		zd->offset = z->offset;
		zd->timestamp = z->timestamp;
		zd->compressMethod = ZIP_COMPMETH_STORED;
		Tcl_SetHashValue(hPtr, zd);
		zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
		zd->next = zf->entries;
		zf->entries = zd;
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
    Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
    Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
    ZipFS.idCount = 1;
    ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE;
    ZipFS.fallbackEntryEncoding = (char *)
	    Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1);
    strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING);
    ZipFS.initialized = 1;
}

/*
 *-------------------------------------------------------------------------
 *
 * ListMountPoints --
 *







|







2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
    Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
    Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
    ZipFS.idCount = 1;
    ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE;
    ZipFS.fallbackEntryEncoding = (char *)
	    Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1);
    strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING);
    ZipFS.initialized = true;
}

/*
 *-------------------------------------------------------------------------
 *
 * ListMountPoints --
 *
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
	ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
	goto done;
    }
    zf = AllocateZipFile(interp, strlen(mountPoint));
    if (zf == NULL) {
	goto done;
    }
    zf->isMemBuffer = 1;
    zf->length = datalen;

    if (copy) {
	zf->data = (unsigned char *)Tcl_AttemptAlloc(datalen);
	if (zf->data == NULL) {
	    ZipFSCloseArchive(interp, zf);
	    Tcl_Free(zf);







|







2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
	ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
	goto done;
    }
    zf = AllocateZipFile(interp, strlen(mountPoint));
    if (zf == NULL) {
	goto done;
    }
    zf->isMemBuffer = true;
    zf->length = datalen;

    if (copy) {
	zf->data = (unsigned char *)Tcl_AttemptAlloc(datalen);
	if (zf->data == NULL) {
	    ZipFSCloseArchive(interp, zf);
	    Tcl_Free(zf);
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
TclZipfs_Unmount(
    Tcl_Interp *interp,		/* Current interpreter. NULLable. */
    const char *mountPoint)	/* Mount point path. */
{
    ZipFile *zf;
    Tcl_HashEntry *hPtr;
    Tcl_DString dsm;
    int ret = TCL_OK, unmounted = 0;

    Tcl_DStringInit(&dsm);

    WriteLock();
    if (!ZipFS.initialized) {
	goto done;
    }







|







2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
TclZipfs_Unmount(
    Tcl_Interp *interp,		/* Current interpreter. NULLable. */
    const char *mountPoint)	/* Mount point path. */
{
    ZipFile *zf;
    Tcl_HashEntry *hPtr;
    Tcl_DString dsm;
    int ret = TCL_OK, unmounted = false;

    Tcl_DStringInit(&dsm);

    WriteLock();
    if (!ZipFS.initialized) {
	goto done;
    }
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
     * still cleaning things up.
     */

    CleanupMount(zf);
    ZipFSCloseArchive(interp, zf);

    Tcl_Free(zf);
    unmounted = 1;

  done:
    Unlock();
    Tcl_DStringFree(&dsm);
    if (unmounted) {
	Tcl_FSMountsChanged(NULL);
    }







|







2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
     * still cleaning things up.
     */

    CleanupMount(zf);
    ZipFSCloseArchive(interp, zf);

    Tcl_Free(zf);
    unmounted = true;

  done:
    Unlock();
    Tcl_DStringFree(&dsm);
    if (unmounted) {
	Tcl_FSMountsChanged(NULL);
    }
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
     * Remember that we've written the file (for central directory generation)
     * and generate the local (per-file) header in the space that we reserved
     * earlier.
     */

    z = AllocateZipEntry();
    Tcl_SetHashValue(hPtr, z);
    z->isEncrypted = (passwd ? 1 : 0);
    z->offset = headerStartOffset;
    z->crc32 = crc;
    z->timestamp = mtime;
    z->numBytes = nbyte;
    z->numCompressedBytes = nbytecompr;
    z->compressMethod = compMeth;
    z->name = (char *) Tcl_GetHashKey(fileHash, hPtr);







|







3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
     * Remember that we've written the file (for central directory generation)
     * and generate the local (per-file) header in the space that we reserved
     * earlier.
     */

    z = AllocateZipEntry();
    Tcl_SetHashValue(hPtr, z);
    z->isEncrypted = (passwd ? true : false);
    z->offset = headerStartOffset;
    z->crc32 = crc;
    z->timestamp = mtime;
    z->numBytes = nbyte;
    z->numCompressedBytes = nbytecompr;
    z->compressMethod = compMeth;
    z->name = (char *) Tcl_GetHashKey(fileHash, hPtr);
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
     * Copy the existing contents from the image if it is an executable image.
     * Care must be taken because this might include an existing ZIP, which
     * needs to be stripped.
     */

    if (isImg) {
	ZipFile *zf, zf0;
	int isMounted = 0;

	// TODO: normalize the origin file name
	const char *imgName = (originFile != NULL) ? TclGetString(originFile) :
		Tcl_GetNameOfExecutable();
	if (pwlen) {
	    Tcl_Size i = 0;
	    for (Tcl_Size len = pwlen; len-- > 0;) {







|







3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
     * Copy the existing contents from the image if it is an executable image.
     * Care must be taken because this might include an existing ZIP, which
     * needs to be stripped.
     */

    if (isImg) {
	ZipFile *zf, zf0;
	bool isMounted = false;

	// TODO: normalize the origin file name
	const char *imgName = (originFile != NULL) ? TclGetString(originFile) :
		Tcl_GetNameOfExecutable();
	if (pwlen) {
	    Tcl_Size i = 0;
	    for (Tcl_Size len = pwlen; len-- > 0;) {
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492

	WriteLock();
	Tcl_HashSearch search;
	for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    zf = (ZipFile *) Tcl_GetHashValue(hPtr);
	    if (strcmp(zf->name, imgName) == 0) {
		isMounted = 1;
		zf->numOpen++;
		break;
	    }
	}
	Unlock();

	if (!isMounted) {







|







3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493

	WriteLock();
	Tcl_HashSearch search;
	for (Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search);
		hPtr; hPtr = Tcl_NextHashEntry(&search)) {
	    zf = (ZipFile *) Tcl_GetHashValue(hPtr);
	    if (strcmp(zf->name, imgName) == 0) {
		isMounted = true;
		zf->numOpen++;
		break;
	    }
	}
	Unlock();

	if (!isMounted) {
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
    ZipEntry *z,		/* The description of what to serialize. */
    int nameLength,		/* The length of the name. */
    int align)			/* The number of alignment bytes. */
{
    ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS,
	    z->isEncrypted + ZIP_LOCAL_FLAGS_UTF8);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS,
	    z->compressMethod);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS,
	    ToDosTime(z->timestamp));
    ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS,
	    ToDosDate(z->timestamp));
    ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);







|







3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
    ZipEntry *z,		/* The description of what to serialize. */
    int nameLength,		/* The length of the name. */
    int align)			/* The number of alignment bytes. */
{
    ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS,
	    (z->isEncrypted ? ZIP_LOCAL_FLAGS_ENC : 0) | ZIP_LOCAL_FLAGS_UTF8);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS,
	    z->compressMethod);
    ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS,
	    ToDosTime(z->timestamp));
    ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS,
	    ToDosDate(z->timestamp));
    ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
{
    ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS,
	    ZIP_CENTRAL_HEADER_SIG);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS,
	    ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS,
	    z->isEncrypted + ZIP_LOCAL_FLAGS_UTF8);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS,
	    z->compressMethod);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS,
	    ToDosTime(z->timestamp));
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS,
	    ToDosDate(z->timestamp));
    ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);







|







3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
{
    ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS,
	    ZIP_CENTRAL_HEADER_SIG);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS,
	    ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS,
	    (z->isEncrypted ? ZIP_LOCAL_FLAGS_ENC : 0) | ZIP_LOCAL_FLAGS_UTF8);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS,
	    z->compressMethod);
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS,
	    ToDosTime(z->timestamp));
    ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS,
	    ToDosDate(z->timestamp));
    ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
	    Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
    Tcl_DecrRefCount(subDirObj);
    Tcl_IncrRefCount(searchPathObj);
    Tcl_SetEncodingSearchPath(searchPathObj);
    Tcl_DecrRefCount(searchPathObj);
    /* Bug [fccb9f322f]. Reinit system encoding after setting search path */
    TclpSetInitialEncodings();
    zipfs_tcl_library_init = 1;
    return libDirObj;
}

Tcl_Obj *
TclZipfs_TclLibrary(void)
{
    Tcl_Obj *vfsInitScript;







|







4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
	    Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
    Tcl_DecrRefCount(subDirObj);
    Tcl_IncrRefCount(searchPathObj);
    Tcl_SetEncodingSearchPath(searchPathObj);
    Tcl_DecrRefCount(searchPathObj);
    /* Bug [fccb9f322f]. Reinit system encoding after setting search path */
    TclpSetInitialEncodings();
    zipfs_tcl_library_init = true;
    return libDirObj;
}

Tcl_Obj *
TclZipfs_TclLibrary(void)
{
    Tcl_Obj *vfsInitScript;
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
    if (zipfs_literal_tcl_library) {
	return ScriptLibrarySetup(zipfs_literal_tcl_library);
    }
    /* 
     * No zipfs tcl-library, mark it to avoid performance penalty [62019f8aa9f5ec73],
     * by future calls (child interpreters, threads, etc).
     */
    zipfs_tcl_library_init = 1;
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSTclLibraryObjCmd --







|







4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
    if (zipfs_literal_tcl_library) {
	return ScriptLibrarySetup(zipfs_literal_tcl_library);
    }
    /* 
     * No zipfs tcl-library, mark it to avoid performance penalty [62019f8aa9f5ec73],
     * by future calls (child interpreters, threads, etc).
     */
    zipfs_tcl_library_init = true;
    return NULL;
}

/*
 *-------------------------------------------------------------------------
 *
 * ZipFSTclLibraryObjCmd --
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
    ZipChannel *info = (ZipChannel *) instanceData;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
	return EINVAL;
    }

    if (info->isEncrypted) {
	info->isEncrypted = 0;
	memset(info->keys, 0, sizeof(info->keys));
    }
    WriteLock();
    if (ZipChannelWritable(info)) {
	/*
	 * Copy channel data back into original file in archive.
	 */







|







4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
    ZipChannel *info = (ZipChannel *) instanceData;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
	return EINVAL;
    }

    if (info->isEncrypted) {
	info->isEncrypted = false;
	memset(info->keys, 0, sizeof(info->keys));
    }
    WriteLock();
    if (ZipChannelWritable(info)) {
	/*
	 * Copy channel data back into original file in archive.
	 */
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
	    Tcl_Free(z->data);
	}
	z->data = newdata; /* May be NULL when ubufToFree was NULL */
	z->numBytes = z->numCompressedBytes = info->numBytes;
	assert(z->data || z->numBytes == 0);
	z->compressMethod = ZIP_COMPMETH_STORED;
	z->timestamp = time(NULL);
	z->isDirectory = 0;
	z->isEncrypted = 0;
	z->offset = 0;
	z->crc32 = 0;
    }
    info->zipFilePtr->numOpen--;
    Unlock();
    if (info->ubufToFree) {
	assert(info->ubuf);







|
|







4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
	    Tcl_Free(z->data);
	}
	z->data = newdata; /* May be NULL when ubufToFree was NULL */
	z->numBytes = z->numCompressedBytes = info->numBytes;
	assert(z->data || z->numBytes == 0);
	z->compressMethod = ZIP_COMPMETH_STORED;
	z->timestamp = time(NULL);
	z->isDirectory = false;
	z->isEncrypted = false;
	z->offset = 0;
	z->crc32 = 0;
    }
    info->zipFilePtr->numOpen--;
    Unlock();
    if (info->ubufToFree) {
	assert(info->ubuf);
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
    ZipChannel *info,		/* The channel to set up. */
    ZipEntry *z)		/* The zipped file that the channel will read
				 * from. */
{
    unsigned char *ubuf = NULL;
    int ch;

    info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
    info->ubuf = z->zipFilePtr->data + z->offset;
    info->ubufToFree = NULL; /* ubuf memory not allocated */
    info->ubufSize = 0;
    info->isDirectory = z->isDirectory;
    info->isEncrypted = z->isEncrypted;
    info->mode = O_RDONLY;

    /* Caller must validate - bug [6ed3447a7e] */
    assert(z->numBytes >= 0 && z->numCompressedBytes >= 0);
    info->numBytes = z->numBytes;

    if (info->isEncrypted) {
	assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
	if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) {
	    goto error_cleanup;
	}
	info->ubuf += ZIP_CRYPT_HDR_LEN;
    }

    if (info->iscompr) {
	z_stream stream;

	/*
	 * Data to decode is compressed, and possibly encrpyted too. If
	 * encrypted, local variable ubuf is used to hold the decrypted but
	 * still compressed data.
	 */







|



















|







5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
    ZipChannel *info,		/* The channel to set up. */
    ZipEntry *z)		/* The zipped file that the channel will read
				 * from. */
{
    unsigned char *ubuf = NULL;
    int ch;

    info->isCompressed = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
    info->ubuf = z->zipFilePtr->data + z->offset;
    info->ubufToFree = NULL; /* ubuf memory not allocated */
    info->ubufSize = 0;
    info->isDirectory = z->isDirectory;
    info->isEncrypted = z->isEncrypted;
    info->mode = O_RDONLY;

    /* Caller must validate - bug [6ed3447a7e] */
    assert(z->numBytes >= 0 && z->numCompressedBytes >= 0);
    info->numBytes = z->numBytes;

    if (info->isEncrypted) {
	assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
	if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) {
	    goto error_cleanup;
	}
	info->ubuf += ZIP_CRYPT_HDR_LEN;
    }

    if (info->isCompressed) {
	z_stream stream;

	/*
	 * Data to decode is compressed, and possibly encrpyted too. If
	 * encrypted, local variable ubuf is used to hold the decrypted but
	 * still compressed data.
	 */
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
	}
	/* Even if decompression succeeded, counts should be as expected */
	if ((int) stream.total_out != z->numBytes) {
	    goto corruptionError;
	}

	if (ubuf) {
	    info->isEncrypted = 0;
	    memset(info->keys, 0, sizeof(info->keys));
	    Tcl_Free(ubuf);
	}
    } else if (info->isEncrypted) {
	/*
	 * Decode encrypted but uncompressed file, since we support Tcl_Seek()
	 * on it, and it can be randomly accessed later.







|







5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
	}
	/* Even if decompression succeeded, counts should be as expected */
	if ((int) stream.total_out != z->numBytes) {
	    goto corruptionError;
	}

	if (ubuf) {
	    info->isEncrypted = false;
	    memset(info->keys, 0, sizeof(info->keys));
	    Tcl_Free(ubuf);
	}
    } else if (info->isEncrypted) {
	/*
	 * Decode encrypted but uncompressed file, since we support Tcl_Seek()
	 * on it, and it can be randomly accessed later.
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
	    ch = info->ubuf[j];
	    ubuf[j] = zdecode(info->keys, crc32tab, ch);
	}
	info->ubufSize = len;
	info->ubufToFree = ubuf;
	info->ubuf = info->ubufToFree;
	ubuf = NULL; /* So it does not inadvertently get free on future changes */
	info->isEncrypted = 0;
    }
    return TCL_OK;

  corruptionError:
    ZIPFS_ERROR(interp, "decompression error");
    ZIPFS_ERROR_CODE(interp, "CORRUPT");
    goto error_cleanup;







|







5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
	    ch = info->ubuf[j];
	    ubuf[j] = zdecode(info->keys, crc32tab, ch);
	}
	info->ubufSize = len;
	info->ubufToFree = ubuf;
	info->ubuf = info->ubufToFree;
	ubuf = NULL; /* So it does not inadvertently get free on future changes */
	info->isEncrypted = false;
    }
    return TCL_OK;

  corruptionError:
    ZIPFS_ERROR(interp, "decompression error");
    ZIPFS_ERROR_CODE(interp, "CORRUPT");
    goto error_cleanup;
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
		if (*tail == '\0') {
		    continue;
		}
		const char *end = strchr(tail, '/');
		Tcl_DStringAppend(&ds, zf->mountPoint + strip,
			end ? (Tcl_Size)(end - zf->mountPoint) : -1);
		const char *matchedPath = Tcl_DStringValue(&ds);
		(void)Tcl_CreateHashEntry(
		    &duplicates, matchedPath, &notDuplicate);
		if (notDuplicate) {
		    AppendWithPrefix(
			result, prefixBuf, matchedPath, Tcl_DStringLength(&ds));
		}
		Tcl_DStringFree(&ds);
	    }
	}
    }
    Tcl_DeleteHashTable(&duplicates);
    Tcl_Free(pat);







|
|

|
|







5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
		if (*tail == '\0') {
		    continue;
		}
		const char *end = strchr(tail, '/');
		Tcl_DStringAppend(&ds, zf->mountPoint + strip,
			end ? (Tcl_Size)(end - zf->mountPoint) : -1);
		const char *matchedPath = Tcl_DStringValue(&ds);
		(void)Tcl_CreateHashEntry(&duplicates, matchedPath,
			&notDuplicate);
		if (notDuplicate) {
		    AppendWithPrefix(result, prefixBuf, matchedPath,
			    Tcl_DStringLength(&ds));
		}
		Tcl_DStringFree(&ds);
	    }
	}
    }
    Tcl_DeleteHashTable(&duplicates);
    Tcl_Free(pat);
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887


5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
 */

static int
ZipFSPathInFilesystemProc(
    Tcl_Obj *pathPtr,
    TCL_UNUSED(void **))
{
    Tcl_Size len;
    char *path;
    int ret, decrRef = 0;

    if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) {
	/*
	 * The cwd is native (or path is absolute), use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	pathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (pathPtr == NULL) {
	    return -1;
	}
	decrRef = 1; /* Tcl_FSGetTranslatedPath increases refCount */
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (!pathPtr) {
	    return -1;
	}
	/* Tcl_FSGetNormalizedPath doesn't increase refCount */
    }


    path = TclGetStringFromObj(pathPtr, &len);

    /*
     * Claim any path under ZIPFS_VOLUME as ours. This is both a necessary
     * and sufficient condition as zipfs mounts at arbitrary paths are
     * not permitted (unlike Androwish).
     */
    ret = (
	(len < ZIPFS_VOLUME_LEN) ||
	strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN)
    ) ? -1 : TCL_OK;

    if (decrRef) {
	Tcl_DecrRefCount(pathPtr);
    }







<
<
|












|











>
>
|






|







5855
5856
5857
5858
5859
5860
5861


5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
 */

static int
ZipFSPathInFilesystemProc(
    Tcl_Obj *pathPtr,
    TCL_UNUSED(void **))
{


    bool decrRef = false;

    if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) {
	/*
	 * The cwd is native (or path is absolute), use the translated path
	 * without worrying about normalization (this will also usually be
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	pathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (pathPtr == NULL) {
	    return -1;
	}
	decrRef = true; /* Tcl_FSGetTranslatedPath increases refCount */
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (!pathPtr) {
	    return -1;
	}
	/* Tcl_FSGetNormalizedPath doesn't increase refCount */
    }

    Tcl_Size len;
    const char *path = TclGetStringFromObj(pathPtr, &len);

    /*
     * Claim any path under ZIPFS_VOLUME as ours. This is both a necessary
     * and sufficient condition as zipfs mounts at arbitrary paths are
     * not permitted (unlike Androwish).
     */
    int ret = (
	(len < ZIPFS_VOLUME_LEN) ||
	strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN)
    ) ? -1 : TCL_OK;

    if (decrRef) {
	Tcl_DecrRefCount(pathPtr);
    }
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
	    }
	}
	if (!objs[0]) {
	    objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
		    TCL_PATH_DIRNAME);
	}
	if (objs[0]) {
	    altPath = TclJoinPath(2, objs, 0);
	    if (altPath) {
		Tcl_IncrRefCount(altPath);
		if (Tcl_FSAccess(altPath, R_OK) == 0) {
		    path = altPath;
		}
	    }
	}







|







6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
	    }
	}
	if (!objs[0]) {
	    objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
		    TCL_PATH_DIRNAME);
	}
	if (objs[0]) {
	    altPath = TclJoinPath(2, objs, false);
	    if (altPath) {
		Tcl_IncrRefCount(altPath);
		if (Tcl_FSAccess(altPath, R_OK) == 0) {
		    path = altPath;
		}
	    }
	}
Changes to generic/tclZlib.c.
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
/*
 * Structure used for the Tcl_ZlibStream* commands and [zlib stream ...]
 */

typedef struct {
    Tcl_Interp *interp;
    z_stream stream;		/* The interface to the zlib library. */
    int streamEnd;		/* If we've got to end-of-stream. */
    Tcl_Obj *inData, *outData;	/* Input / output buffers (lists) */
    Tcl_Obj *currentInput;	/* Pointer to what is currently being
				 * inflated. */
    Tcl_Size outPos;		/* Index into output buffer to write to next. */
    int mode;			/* Either TCL_ZLIB_STREAM_DEFLATE or
				 * TCL_ZLIB_STREAM_INFLATE. */
    int format;			/* Flags from the TCL_ZLIB_FORMAT_* */







|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
/*
 * Structure used for the Tcl_ZlibStream* commands and [zlib stream ...]
 */

typedef struct {
    Tcl_Interp *interp;
    z_stream stream;		/* The interface to the zlib library. */
    bool streamEnd;		/* If we've got to end-of-stream. */
    Tcl_Obj *inData, *outData;	/* Input / output buffers (lists) */
    Tcl_Obj *currentInput;	/* Pointer to what is currently being
				 * inflated. */
    Tcl_Size outPos;		/* Index into output buffer to write to next. */
    int mode;			/* Either TCL_ZLIB_STREAM_DEFLATE or
				 * TCL_ZLIB_STREAM_INFLATE. */
    int format;			/* Flags from the TCL_ZLIB_FORMAT_* */
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
    zshPtr = (ZlibStreamHandle *) Tcl_Alloc(sizeof(ZlibStreamHandle));
    zshPtr->interp = interp;
    zshPtr->mode = mode;
    zshPtr->format = format;
    zshPtr->level = level;
    zshPtr->wbits = wbits;
    zshPtr->currentInput = NULL;
    zshPtr->streamEnd = 0;
    zshPtr->compDictObj = NULL;
    zshPtr->flags = 0;
    zshPtr->gzHeaderPtr = gzHeaderPtr;
    memset(&zshPtr->stream, 0, sizeof(z_stream));
    zshPtr->stream.adler = 1;

    /*







|







772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
    zshPtr = (ZlibStreamHandle *) Tcl_Alloc(sizeof(ZlibStreamHandle));
    zshPtr->interp = interp;
    zshPtr->mode = mode;
    zshPtr->format = format;
    zshPtr->level = level;
    zshPtr->wbits = wbits;
    zshPtr->currentInput = NULL;
    zshPtr->streamEnd = false;
    zshPtr->compDictObj = NULL;
    zshPtr->flags = 0;
    zshPtr->gzHeaderPtr = gzHeaderPtr;
    memset(&zshPtr->stream, 0, sizeof(z_stream));
    zshPtr->stream.adler = 1;

    /*
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
    Tcl_SetByteArrayLength(zshPtr->outData, 0);
    if (zshPtr->currentInput) {
	Tcl_DecrRefCount(zshPtr->currentInput);
	zshPtr->currentInput = NULL;
    }

    zshPtr->outPos = 0;
    zshPtr->streamEnd = 0;
    memset(&zshPtr->stream, 0, sizeof(z_stream));

    /*
     * No output buffer available yet.
     */

    if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {







|







1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
    Tcl_SetByteArrayLength(zshPtr->outData, 0);
    if (zshPtr->currentInput) {
	Tcl_DecrRefCount(zshPtr->currentInput);
	zshPtr->currentInput = NULL;
    }

    zshPtr->outPos = 0;
    zshPtr->streamEnd = false;
    memset(&zshPtr->stream, 0, sizeof(z_stream));

    /*
     * No output buffer available yet.
     */

    if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
	}
	if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) {
	    Tcl_SetByteArrayLength(data, existing);
	    ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
	    return TCL_ERROR;
	}
	if (e == Z_STREAM_END) {
	    zshPtr->streamEnd = 1;
	    if (zshPtr->currentInput) {
		Tcl_DecrRefCount(zshPtr->currentInput);
		zshPtr->currentInput = 0;
	    }
	    inflateEnd(&zshPtr->stream);
	}
    } else {
	TclListObjLength(NULL, zshPtr->outData, &listLen);
	if (count < 0) {
	    count = 0;







|


|







1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
	}
	if (!(e==Z_OK || e==Z_STREAM_END || e==Z_BUF_ERROR)) {
	    Tcl_SetByteArrayLength(data, existing);
	    ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
	    return TCL_ERROR;
	}
	if (e == Z_STREAM_END) {
	    zshPtr->streamEnd = true;
	    if (zshPtr->currentInput) {
		Tcl_DecrRefCount(zshPtr->currentInput);
		zshPtr->currentInput = NULL;
	    }
	    inflateEnd(&zshPtr->stream);
	}
    } else {
	TclListObjLength(NULL, zshPtr->outData, &listLen);
	if (count < 0) {
	    count = 0;
Changes to macosx/tclMacOSXNotify.c.
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
 * select based implementation of the Tcl notifier. One of these structures is
 * created for each thread that is using the notifier.
 */
typedef struct ThreadSpecificData_Notifier_macOS ThreadSpecificData;
struct ThreadSpecificData_Notifier_macOS {
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */
    int polled;			/* True if the notifier thread has polled for
				 * this thread. */
    int sleeping;		/* True if runloop is inside Tcl_Sleep. */
    int runLoopSourcePerformed;	/* True after the runLoopSource callack was
				 * performed. */
    int runLoopRunning;		/* True if this thread's Tcl runLoop is
				 * running. */
    int runLoopNestingLevel;	/* Level of nested runLoop invocations. */

    /* Must hold the notifierLock before accessing the following fields: */
    /* Start notifierLock section */
    int onList;			/* True if this thread is on the
				 * waitingList */
    ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed
				 * from these pointers. */
    /* End notifierLock section */







|

|
|

|





|







196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
 * select based implementation of the Tcl notifier. One of these structures is
 * created for each thread that is using the notifier.
 */
typedef struct ThreadSpecificData_Notifier_macOS ThreadSpecificData;
struct ThreadSpecificData_Notifier_macOS {
    FileHandler *firstFileHandlerPtr;
				/* Pointer to head of file handler list. */
    bool polled;		/* True if the notifier thread has polled for
				 * this thread. */
    bool sleeping;		/* True if runloop is inside Tcl_Sleep. */
    bool runLoopSourcePerformed;/* True after the runLoopSource callack was
				 * performed. */
    bool runLoopRunning;	/* True if this thread's Tcl runLoop is
				 * running. */
    int runLoopNestingLevel;	/* Level of nested runLoop invocations. */

    /* Must hold the notifierLock before accessing the following fields: */
    /* Start notifierLock section */
    bool onList;		/* True if this thread is on the
				 * waitingList */
    ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed
				 * from these pointers. */
    /* End notifierLock section */
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
				 * to Tcl_CreateFileHandler. */
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
    int polling;		/* True if this thread is polling for
				 * events. */
    CFRunLoopRef runLoop;	/* This thread's CFRunLoop, needs to be woken
				 * up whenever the runLoopSource is
				 * signaled. */
    CFRunLoopSourceRef runLoopSource;
				/* Any other thread alerts a notifier that an
				 * event is ready to be processed by signaling







|







235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
				 * to Tcl_CreateFileHandler. */
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
    bool polling;		/* True if this thread is polling for
				 * events. */
    CFRunLoopRef runLoop;	/* This thread's CFRunLoop, needs to be woken
				 * up whenever the runLoopSource is
				 * signaled. */
    CFRunLoopSourceRef runLoopSource;
				/* Any other thread alerts a notifier that an
				 * event is ready to be processed by signaling
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

/*
 * The following static indicates if the notifier thread is running.
 *
 * You must hold the notifierInitLock before accessing this variable.
 */

static int notifierThreadRunning;

/*
 * The following static flag indicates that async handlers are pending.
 */

#if TCL_THREADS
static int asyncPending = 0;
#endif

/*
 * Signal mask information for notifier thread.
 */
static sigset_t notifierSigMask;
static sigset_t allSigMask;

/*
 * This is the thread ID of the notifier thread that does select. Only valid
 * when notifierThreadRunning is non-zero.
 *
 * You must hold the notifierInitLock before accessing this variable.
 */

static pthread_t notifierThread;

/*







|






|










|







300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

/*
 * The following static indicates if the notifier thread is running.
 *
 * You must hold the notifierInitLock before accessing this variable.
 */

static bool notifierThreadRunning;

/*
 * The following static flag indicates that async handlers are pending.
 */

#if TCL_THREADS
static bool asyncPending = false;
#endif

/*
 * Signal mask information for notifier thread.
 */
static sigset_t notifierSigMask;
static sigset_t allSigMask;

/*
 * This is the thread ID of the notifier thread that does select. Only valid
 * when notifierThreadRunning is true.
 *
 * You must hold the notifierInitLock before accessing this variable.
 */

static pthread_t notifierThread;

/*
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
static TCL_NORETURN void NotifierThreadProc(void *clientData);
static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);
static void		TimerWakeUp(CFRunLoopTimerRef timer, void *info);
static void		QueueFileEvents(void *info);
static void		UpdateWaitingListAndServiceEvents(
			    CFRunLoopObserverRef observer,
			    CFRunLoopActivity activity, void *info);
static int		OnOffWaitingList(ThreadSpecificData *tsdPtr,
			    int onList, int signalNotifier);

#ifdef HAVE_PTHREAD_ATFORK
static int atForkInit = 0;
static void		AtForkPrepare(void);
static void		AtForkParent(void);
static void		AtForkChild(void);

#endif /* HAVE_PTHREAD_ATFORK */

/*







|
|


|







357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
static TCL_NORETURN void NotifierThreadProc(void *clientData);
static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);
static void		TimerWakeUp(CFRunLoopTimerRef timer, void *info);
static void		QueueFileEvents(void *info);
static void		UpdateWaitingListAndServiceEvents(
			    CFRunLoopObserverRef observer,
			    CFRunLoopActivity activity, void *info);
static bool		OnOffWaitingList(ThreadSpecificData *tsdPtr,
			    bool onList, bool signalNotifier);

#ifdef HAVE_PTHREAD_ATFORK
static bool atForkInit = false;
static void		AtForkPrepare(void);
static void		AtForkParent(void);
static void		AtForkChild(void);

#endif /* HAVE_PTHREAD_ATFORK */

/*
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

    if (!atForkInit) {
	int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);

	if (result) {
	    Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
	}
	atForkInit = 1;
    }
#endif /* HAVE_PTHREAD_ATFORK */
    if (notifierCount == 0) {
	int fds[2], status;

	/*
	 * Initialize trigger pipe.







|







535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

    if (!atForkInit) {
	int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);

	if (result) {
	    Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
	}
	atForkInit = true;
    }
#endif /* HAVE_PTHREAD_ATFORK */
    if (notifierCount == 0) {
	int fds[2], status;

	/*
	 * Initialize trigger pipe.
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585

	/*
	 * Create notifier thread lazily in Tcl_WaitForEvent() to avoid
	 * interfering with fork() followed immediately by execve() (we cannot
	 * execve() when more than one thread is present).
	 */

	notifierThreadRunning = 0;
    }
    notifierCount++;
    UNLOCK_NOTIFIER_INIT;
    return tsdPtr;
}

/*







|







571
572
573
574
575
576
577
578
579
580
581
582
583
584
585

	/*
	 * Create notifier thread lazily in Tcl_WaitForEvent() to avoid
	 * interfering with fork() followed immediately by execve() (we cannot
	 * execve() when more than one thread is present).
	 */

	notifierThreadRunning = false;
    }
    notifierCount++;
    UNLOCK_NOTIFIER_INIT;
    return tsdPtr;
}

/*
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
StartNotifierThread(void)
{
    LOCK_NOTIFIER_INIT;
    if (!notifierCount) {
	Tcl_Panic("StartNotifierThread: notifier not initialized");
    }
    if (!notifierThreadRunning) {
	int result;
	pthread_attr_t attr;

	/*
	 * Arrange for the notifier thread to start with all
	 * signals blocked. In its mainloop it unblocks the
	 * signals at safe points.
	 */

	sigfillset(&allSigMask);
	pthread_sigmask(SIG_BLOCK, &allSigMask, &notifierSigMask);


	pthread_attr_init(&attr);
	pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
	pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
	pthread_attr_setstacksize(&attr, 60 * 1024);
	result = pthread_create(&notifierThread, &attr,
		(void * (*)(void *)) NotifierThreadProc, NULL);
	pthread_attr_destroy(&attr);
	if (result) {
	    Tcl_Panic("StartNotifierThread: unable to start notifier thread");
	}
	notifierThreadRunning = 1;

	/*
	 * Restore original signal mask.
	 */

	pthread_sigmask(SIG_SETMASK, &notifierSigMask, NULL);
    }







<
<
<









>




|





|







635
636
637
638
639
640
641



642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
StartNotifierThread(void)
{
    LOCK_NOTIFIER_INIT;
    if (!notifierCount) {
	Tcl_Panic("StartNotifierThread: notifier not initialized");
    }
    if (!notifierThreadRunning) {



	/*
	 * Arrange for the notifier thread to start with all
	 * signals blocked. In its mainloop it unblocks the
	 * signals at safe points.
	 */

	sigfillset(&allSigMask);
	pthread_sigmask(SIG_BLOCK, &allSigMask, &notifierSigMask);

	pthread_attr_t attr;
	pthread_attr_init(&attr);
	pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
	pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
	pthread_attr_setstacksize(&attr, 60 * 1024);
	int result = pthread_create(&notifierThread, &attr,
		(void * (*)(void *)) NotifierThreadProc, NULL);
	pthread_attr_destroy(&attr);
	if (result) {
	    Tcl_Panic("StartNotifierThread: unable to start notifier thread");
	}
	notifierThreadRunning = true;

	/*
	 * Restore original signal mask.
	 */

	pthread_sigmask(SIG_SETMASK, &notifierSigMask, NULL);
    }
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
	    if (notifierThreadRunning) {
		int result = pthread_join(notifierThread, NULL);

		if (result) {
		    Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier "
			    "thread");
		}
		notifierThreadRunning = 0;

		/*
		 * If async marks are outstanding, perform actions now.
		 */
		if (asyncPending) {
		    asyncPending = 0;
		    TclAsyncMarkFromNotifier();
		}
	    }

	    close(receivePipe);
	    triggerPipe = -1;
	}







|





|







721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
	    if (notifierThreadRunning) {
		int result = pthread_join(notifierThread, NULL);

		if (result) {
		    Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier "
			    "thread");
		}
		notifierThreadRunning = false;

		/*
		 * If async marks are outstanding, perform actions now.
		 */
		if (asyncPending) {
		    asyncPending = false;
		    TclAsyncMarkFromNotifier();
		}
	    }

	    close(receivePipe);
	    triggerPipe = -1;
	}
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.







|







1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
	    if (mask & TCL_EXCEPTION) {
		FD_CLR(filePtr->fd, &tsdPtr->readyMasks.exceptional);
	    }
	    UNLOCK_NOTIFIER_TSD;
	    filePtr->proc(filePtr->clientData, mask);
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpNotifierData --
 *







|







1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
	    if (mask & TCL_EXCEPTION) {
		FD_CLR(filePtr->fd, &tsdPtr->readyMasks.exceptional);
	    }
	    UNLOCK_NOTIFIER_TSD;
	    filePtr->proc(filePtr->clientData, mask);
	}
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpNotifierData --
 *
1181
1182
1183
1184
1185
1186
1187

1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
 *----------------------------------------------------------------------
 */

int
TclpWaitForEvent(
    const Tcl_Time *timePtr)	/* Maximum block time, or NULL. */
{

    int result, polling, runLoopRunning;
    CFTimeInterval waitTime;
    SInt32 runLoopStatus;
    ThreadSpecificData *tsdPtr;

    result = -1;
    polling = 0;
    waitTime = CF_TIMEINTERVAL_FOREVER;
    tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->runLoop) {
	Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
    }








>
|





|







1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
 *----------------------------------------------------------------------
 */

int
TclpWaitForEvent(
    const Tcl_Time *timePtr)	/* Maximum block time, or NULL. */
{
    int result;
    bool polling, runLoopRunning;
    CFTimeInterval waitTime;
    SInt32 runLoopStatus;
    ThreadSpecificData *tsdPtr;

    result = -1;
    polling = false;
    waitTime = CF_TIMEINTERVAL_FOREVER;
    tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->runLoop) {
	Tcl_Panic("Tcl_WaitForEvent: Notifier not initialized");
    }

1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
	     * or timers are ready to fire immediately, only one (possibly two
	     * if one is a version 0 source) will be fired, regardless of the
	     * value of returnAfterSourceHandled."  This can cause some chanio
	     * tests to fail.  So we use a small positive waitTime unless
	     * there is another RunLoop running.
	     */

	    polling = 1;
	    waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001;
	}
    }

    StartNotifierThread();

    LOCK_NOTIFIER_TSD;
    tsdPtr->polling = polling;
    UNLOCK_NOTIFIER_TSD;
    tsdPtr->runLoopSourcePerformed = 0;

    /*
     * If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was
     * called recursively) start a new runloop in a custom runloop mode
     * containing only the source for the notifier thread.  Otherwise wakeups
     * from other sources added to the common runloop mode might get lost or
     * 3rd party event handlers might get called when they do not expect to
     * be.
     */

    runLoopRunning = tsdPtr->runLoopRunning;
    tsdPtr->runLoopRunning = 1;
    runLoopStatus = CFRunLoopRunInMode(
	runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode,
	waitTime, TRUE);
    tsdPtr->runLoopRunning = runLoopRunning;

    LOCK_NOTIFIER_TSD;
    tsdPtr->polling = 0;
    UNLOCK_NOTIFIER_TSD;
    switch (runLoopStatus) {
    case kCFRunLoopRunFinished:
	Tcl_Panic("Tcl_WaitForEvent: CFRunLoop finished");
	break;
    case kCFRunLoopRunTimedOut:
	QueueFileEvents(tsdPtr);







|









|











|






|







1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
	     * or timers are ready to fire immediately, only one (possibly two
	     * if one is a version 0 source) will be fired, regardless of the
	     * value of returnAfterSourceHandled."  This can cause some chanio
	     * tests to fail.  So we use a small positive waitTime unless
	     * there is another RunLoop running.
	     */

	    polling = true;
	    waitTime = tsdPtr->runLoopRunning ? 0 : 0.0001;
	}
    }

    StartNotifierThread();

    LOCK_NOTIFIER_TSD;
    tsdPtr->polling = polling;
    UNLOCK_NOTIFIER_TSD;
    tsdPtr->runLoopSourcePerformed = false;

    /*
     * If the Tcl runloop is already running (e.g. if Tcl_WaitForEvent was
     * called recursively) start a new runloop in a custom runloop mode
     * containing only the source for the notifier thread.  Otherwise wakeups
     * from other sources added to the common runloop mode might get lost or
     * 3rd party event handlers might get called when they do not expect to
     * be.
     */

    runLoopRunning = tsdPtr->runLoopRunning;
    tsdPtr->runLoopRunning = true;
    runLoopStatus = CFRunLoopRunInMode(
	runLoopRunning ? tclEventsOnlyRunLoopMode : kCFRunLoopDefaultMode,
	waitTime, TRUE);
    tsdPtr->runLoopRunning = runLoopRunning;

    LOCK_NOTIFIER_TSD;
    tsdPtr->polling = false;
    UNLOCK_NOTIFIER_TSD;
    switch (runLoopStatus) {
    case kCFRunLoopRunFinished:
	Tcl_Panic("Tcl_WaitForEvent: CFRunLoop finished");
	break;
    case kCFRunLoopRunTimedOut:
	QueueFileEvents(tsdPtr);
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
    FD_COPY(&tsdPtr->readyMasks.readable, &readyMasks.readable);
    FD_COPY(&tsdPtr->readyMasks.writable, &readyMasks.writable);
    FD_COPY(&tsdPtr->readyMasks.exceptional, &readyMasks.exceptional);
    FD_ZERO(&tsdPtr->readyMasks.readable);
    FD_ZERO(&tsdPtr->readyMasks.writable);
    FD_ZERO(&tsdPtr->readyMasks.exceptional);
    UNLOCK_NOTIFIER_TSD;
    tsdPtr->runLoopSourcePerformed = 1;

    for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
	    filePtr = filePtr->nextPtr) {
	int mask = 0;

	if (FD_ISSET(filePtr->fd, &readyMasks.readable)) {
	    mask |= TCL_READABLE;







|







1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
    FD_COPY(&tsdPtr->readyMasks.readable, &readyMasks.readable);
    FD_COPY(&tsdPtr->readyMasks.writable, &readyMasks.writable);
    FD_COPY(&tsdPtr->readyMasks.exceptional, &readyMasks.exceptional);
    FD_ZERO(&tsdPtr->readyMasks.readable);
    FD_ZERO(&tsdPtr->readyMasks.writable);
    FD_ZERO(&tsdPtr->readyMasks.exceptional);
    UNLOCK_NOTIFIER_TSD;
    tsdPtr->runLoopSourcePerformed = true;

    for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
	    filePtr = filePtr->nextPtr) {
	int mask = 0;

	if (FD_ISSET(filePtr->fd, &readyMasks.readable)) {
	    mask |= TCL_READABLE;
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
	return;
    }
    switch (activity) {
    case kCFRunLoopEntry:
	tsdPtr->runLoopNestingLevel++;
	if (tsdPtr->numFdBits > 0 || tsdPtr->polling) {
	    LOCK_NOTIFIER;
	    if (!OnOffWaitingList(tsdPtr, 1, 1) && tsdPtr->polling) {
		write(triggerPipe, "", 1);
	    }
	    UNLOCK_NOTIFIER;
	}
	break;
    case kCFRunLoopExit:
	if (tsdPtr->runLoopNestingLevel == 1) {
	    LOCK_NOTIFIER;
	    OnOffWaitingList(tsdPtr, 0, 1);
	    UNLOCK_NOTIFIER;
	}
	tsdPtr->runLoopNestingLevel--;
	break;
    default:
	break;
    }







|








|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
	return;
    }
    switch (activity) {
    case kCFRunLoopEntry:
	tsdPtr->runLoopNestingLevel++;
	if (tsdPtr->numFdBits > 0 || tsdPtr->polling) {
	    LOCK_NOTIFIER;
	    if (!OnOffWaitingList(tsdPtr, true, true) && tsdPtr->polling) {
		write(triggerPipe, "", 1);
	    }
	    UNLOCK_NOTIFIER;
	}
	break;
    case kCFRunLoopExit:
	if (tsdPtr->runLoopNestingLevel == 1) {
	    LOCK_NOTIFIER;
	    OnOffWaitingList(tsdPtr, false, true);
	    UNLOCK_NOTIFIER;
	}
	tsdPtr->runLoopNestingLevel--;
	break;
    default:
	break;
    }
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
1455
1456
1457
1458
1459
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
OnOffWaitingList(
    ThreadSpecificData *tsdPtr,
    int onList,
    int signalNotifier)
{
    int changeWaitingList;

    changeWaitingList = (!onList ^ !tsdPtr->onList);
    if (changeWaitingList) {
	if (onList) {
	    tsdPtr->nextPtr = waitingListPtr;
	    if (waitingListPtr) {
		waitingListPtr->prevPtr = tsdPtr;
	    }
	    tsdPtr->prevPtr = NULL;
	    waitingListPtr = tsdPtr;
	    tsdPtr->onList = 1;
	} else {
	    if (tsdPtr->prevPtr) {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	    } else {
		waitingListPtr = tsdPtr->nextPtr;
	    }
	    if (tsdPtr->nextPtr) {
		tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	    }
	    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	    tsdPtr->onList = 0;
	}
	if (signalNotifier) {
	    write(triggerPipe, "", 1);
	}
    }

    return changeWaitingList;







|


|
|

|










|










|







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
1455
1456
1457
1458
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static bool
OnOffWaitingList(
    ThreadSpecificData *tsdPtr,
    bool onList,
    bool signalNotifier)
{
    bool changeWaitingList;

    changeWaitingList = (!onList ^ !tsdPtr->onList);
    if (changeWaitingList) {
	if (onList) {
	    tsdPtr->nextPtr = waitingListPtr;
	    if (waitingListPtr) {
		waitingListPtr->prevPtr = tsdPtr;
	    }
	    tsdPtr->prevPtr = NULL;
	    waitingListPtr = tsdPtr;
	    tsdPtr->onList = true;
	} else {
	    if (tsdPtr->prevPtr) {
		tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
	    } else {
		waitingListPtr = tsdPtr->nextPtr;
	    }
	    if (tsdPtr->nextPtr) {
		tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	    }
	    tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	    tsdPtr->onList = false;
	}
	if (signalNotifier) {
	    write(triggerPipe, "", 1);
	}
    }

    return changeWaitingList;
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
1538
1539
	    if (nextTimerFire < waitEnd) {
		CFRunLoopTimerSetNextFireDate(runLoopTimer, now +
			CF_TIMEINTERVAL_FOREVER);
	    } else {
		runLoopTimer = NULL;
	    }
	}
	tsdPtr->sleeping = 1;
	do {
	    runLoopStatus = CFRunLoopRunInMode(kCFRunLoopDefaultMode,
		    waitTime, FALSE);
	    switch (runLoopStatus) {
	    case kCFRunLoopRunFinished:
		Tcl_Panic("Tcl_Sleep: CFRunLoop finished");
		break;
	    case kCFRunLoopRunStopped:
		waitTime = waitEnd - CFAbsoluteTimeGetCurrent();
		break;
	    case kCFRunLoopRunTimedOut:
		waitTime = 0;
		break;
	    }
	} while (waitTime > 0);
	tsdPtr->sleeping = 0;
	if (runLoopTimer) {
	    CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire);
	}
    } else {
	struct timespec waitTime;

	waitTime.tv_sec = vdelay.sec;







|















|







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
1538
	    if (nextTimerFire < waitEnd) {
		CFRunLoopTimerSetNextFireDate(runLoopTimer, now +
			CF_TIMEINTERVAL_FOREVER);
	    } else {
		runLoopTimer = NULL;
	    }
	}
	tsdPtr->sleeping = true;
	do {
	    runLoopStatus = CFRunLoopRunInMode(kCFRunLoopDefaultMode,
		    waitTime, FALSE);
	    switch (runLoopStatus) {
	    case kCFRunLoopRunFinished:
		Tcl_Panic("Tcl_Sleep: CFRunLoop finished");
		break;
	    case kCFRunLoopRunStopped:
		waitTime = waitEnd - CFAbsoluteTimeGetCurrent();
		break;
	    case kCFRunLoopRunTimedOut:
		waitTime = 0;
		break;
	    }
	} while (waitTime > 0);
	tsdPtr->sleeping = false;
	if (runLoopTimer) {
	    CFRunLoopTimerSetNextFireDate(runLoopTimer, nextTimerFire);
	}
    } else {
	struct timespec waitTime;

	waitTime.tv_sec = vdelay.sec;
1716
1717
1718
1719
1720
1721
1722
1723

1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
 * Side effetcs:
 *	The trigger pipe is written when called from the notifier
 *	thread.
 *
 *----------------------------------------------------------------------
 */

int

TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),	/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) notifierThread)) {
	if (notifierThreadRunning) {
	    *flagPtr = value;
	    if (!asyncPending) {
		asyncPending = 1;
		write(triggerPipe, "S", 1);
	    }
	    return 1;
	}
	return 0;
    }

    /*
     * Re-send the signal to the notifier thread.
     */

    pthread_kill((pthread_t) notifierThread, sigNumber);
#endif
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *







<
>



















|


|

|








|







1715
1716
1717
1718
1719
1720
1721

1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
 * Side effetcs:
 *	The trigger pipe is written when called from the notifier
 *	thread.
 *
 *----------------------------------------------------------------------
 */


bool
TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),	/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) notifierThread)) {
	if (notifierThreadRunning) {
	    *flagPtr = value;
	    if (!asyncPending) {
		asyncPending = true;
		write(triggerPipe, "S", 1);
	    }
	    return true;
	}
	return false;
    }

    /*
     * Re-send the signal to the notifier thread.
     */

    pthread_kill((pthread_t) notifierThread, sigNumber);
#endif
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797

static TCL_NORETURN void
NotifierThreadProc(
    TCL_UNUSED(void *))
{
    ThreadSpecificData *tsdPtr;
    fd_set readableMask, writableMask, exceptionalMask;
    int ret, numFdBits = 0, polling;
    struct timeval poll = {0., 0.}, *timePtr;
    char buf[2];

    /*
     * Look for file events and report them to interested threads.
     */








|







1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796

static TCL_NORETURN void
NotifierThreadProc(
    TCL_UNUSED(void *))
{
    ThreadSpecificData *tsdPtr;
    fd_set readableMask, writableMask, exceptionalMask;
    int ret, numFdBits = 0;
    struct timeval poll = {0., 0.}, *timePtr;
    char buf[2];

    /*
     * Look for file events and report them to interested threads.
     */

1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
		if (FD_ISSET(i, &tsdPtr->checkMasks.exceptional)) {
		    FD_SET(i, &exceptionalMask);
		}
	    }
	    if (tsdPtr->numFdBits > numFdBits) {
		numFdBits = tsdPtr->numFdBits;
	    }
	    polling = tsdPtr->polling;
	    UNLOCK_NOTIFIER_TSD;
	    if ((tsdPtr->polled = polling)) {
		timePtr = &poll;
	    }
	}
	UNLOCK_NOTIFIER;








|







1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
		if (FD_ISSET(i, &tsdPtr->checkMasks.exceptional)) {
		    FD_SET(i, &exceptionalMask);
		}
	    }
	    if (tsdPtr->numFdBits > numFdBits) {
		numFdBits = tsdPtr->numFdBits;
	    }
	    bool polling = tsdPtr->polling;
	    UNLOCK_NOTIFIER_TSD;
	    if ((tsdPtr->polled = polling)) {
		timePtr = &poll;
	    }
	}
	UNLOCK_NOTIFIER;

1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
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
1925
1926
1927
1928
1929

	if (ret == -1) {
	    /*
	     * In case a signal was caught during select(),
	     * perform work on async handlers now.
	     */
	    if (errno == EINTR && asyncPending) {
		asyncPending = 0;
		TclAsyncMarkFromNotifier();
	    }

	    /*
	     * Try again immediately on an error.
	     */

	    continue;
	}

	/*
	 * Alert any threads that are waiting on a ready file descriptor.
	 */

	LOCK_NOTIFIER;
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    int found = 0;
	    SelectMasks readyMasks, checkMasks;

	    LOCK_NOTIFIER_TSD;
	    FD_COPY(&tsdPtr->checkMasks.readable, &checkMasks.readable);
	    FD_COPY(&tsdPtr->checkMasks.writable, &checkMasks.writable);
	    FD_COPY(&tsdPtr->checkMasks.exceptional, &checkMasks.exceptional);
	    UNLOCK_NOTIFIER_TSD;
	    found = tsdPtr->polled;
	    FD_ZERO(&readyMasks.readable);
	    FD_ZERO(&readyMasks.writable);
	    FD_ZERO(&readyMasks.exceptional);

	    for (int i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &checkMasks.readable)
			&& FD_ISSET(i, &readableMask)) {
		    FD_SET(i, &readyMasks.readable);
		    found = 1;
		}
		if (FD_ISSET(i, &checkMasks.writable)
			&& FD_ISSET(i, &writableMask)) {
		    FD_SET(i, &readyMasks.writable);
		    found = 1;
		}
		if (FD_ISSET(i, &checkMasks.exceptional)
			&& FD_ISSET(i, &exceptionalMask)) {
		    FD_SET(i, &readyMasks.exceptional);
		    found = 1;
		}
	    }

	    if (found) {
		/*
		 * Remove the ThreadSpecificData structure of this thread from
		 * the waiting list. This prevents us from spinning
		 * continuously on select until the other threads runs and
		 * services the file event.
		 */

		OnOffWaitingList(tsdPtr, 0, 0);

		LOCK_NOTIFIER_TSD;
		FD_COPY(&readyMasks.readable, &tsdPtr->readyMasks.readable);
		FD_COPY(&readyMasks.writable, &tsdPtr->readyMasks.writable);
		FD_COPY(&readyMasks.exceptional,
			&tsdPtr->readyMasks.exceptional);
		UNLOCK_NOTIFIER_TSD;
		tsdPtr->polled = 0;
		if (tsdPtr->runLoop) {
		    CFRunLoopSourceSignal(tsdPtr->runLoopSource);
		    CFRunLoopWakeUp(tsdPtr->runLoop);
		}
	    }
	}
	UNLOCK_NOTIFIER;







|
















|
















|




|




|











|







|







1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
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
1925
1926
1927
1928

	if (ret == -1) {
	    /*
	     * In case a signal was caught during select(),
	     * perform work on async handlers now.
	     */
	    if (errno == EINTR && asyncPending) {
		asyncPending = false;
		TclAsyncMarkFromNotifier();
	    }

	    /*
	     * Try again immediately on an error.
	     */

	    continue;
	}

	/*
	 * Alert any threads that are waiting on a ready file descriptor.
	 */

	LOCK_NOTIFIER;
	for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
	    bool found = false;
	    SelectMasks readyMasks, checkMasks;

	    LOCK_NOTIFIER_TSD;
	    FD_COPY(&tsdPtr->checkMasks.readable, &checkMasks.readable);
	    FD_COPY(&tsdPtr->checkMasks.writable, &checkMasks.writable);
	    FD_COPY(&tsdPtr->checkMasks.exceptional, &checkMasks.exceptional);
	    UNLOCK_NOTIFIER_TSD;
	    found = tsdPtr->polled;
	    FD_ZERO(&readyMasks.readable);
	    FD_ZERO(&readyMasks.writable);
	    FD_ZERO(&readyMasks.exceptional);

	    for (int i = tsdPtr->numFdBits-1; i >= 0; --i) {
		if (FD_ISSET(i, &checkMasks.readable)
			&& FD_ISSET(i, &readableMask)) {
		    FD_SET(i, &readyMasks.readable);
		    found = true;
		}
		if (FD_ISSET(i, &checkMasks.writable)
			&& FD_ISSET(i, &writableMask)) {
		    FD_SET(i, &readyMasks.writable);
		    found = true;
		}
		if (FD_ISSET(i, &checkMasks.exceptional)
			&& FD_ISSET(i, &exceptionalMask)) {
		    FD_SET(i, &readyMasks.exceptional);
		    found = true;
		}
	    }

	    if (found) {
		/*
		 * Remove the ThreadSpecificData structure of this thread from
		 * the waiting list. This prevents us from spinning
		 * continuously on select until the other threads runs and
		 * services the file event.
		 */

		OnOffWaitingList(tsdPtr, false, false);

		LOCK_NOTIFIER_TSD;
		FD_COPY(&readyMasks.readable, &tsdPtr->readyMasks.readable);
		FD_COPY(&readyMasks.writable, &tsdPtr->readyMasks.writable);
		FD_COPY(&readyMasks.exceptional,
			&tsdPtr->readyMasks.exceptional);
		UNLOCK_NOTIFIER_TSD;
		tsdPtr->polled = false;
		if (tsdPtr->runLoop) {
		    CFRunLoopSourceSignal(tsdPtr->runLoopSource);
		    CFRunLoopWakeUp(tsdPtr->runLoop);
		}
	    }
	}
	UNLOCK_NOTIFIER;
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
		 * pipe so we need to shut down the notifier thread.
		 */

		break;
	    }

	    if (asyncPending) {
		asyncPending = 0;
		TclAsyncMarkFromNotifier();
	    }
	}
    }
    pthread_exit(0);
}








|







1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
		 * pipe so we need to shut down the notifier thread.
		 */

		break;
	    }

	    if (asyncPending) {
		asyncPending = false;
		TclAsyncMarkFromNotifier();
	    }
	}
    }
    pthread_exit(0);
}

2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
    tsdPtr->tsdLock  = OS_UNFAIR_LOCK_INIT;
#else
    UNLOCK_NOTIFIER_TSD;
    UNLOCK_NOTIFIER;
    UNLOCK_NOTIFIER_INIT;
#endif

    asyncPending = 0;

    if (tsdPtr->runLoop) {
	tsdPtr->runLoop = NULL;
	tsdPtr->runLoopSource = NULL;
	tsdPtr->runLoopTimer = NULL;
    }
    if (notifierCount > 0) {
	notifierCount = 1;
	notifierThreadRunning = 0;

	/*
	 * Restart the notifier thread for signal handling.
	 */

	StartNotifierThread();
    }







|








|







2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
    tsdPtr->tsdLock  = OS_UNFAIR_LOCK_INIT;
#else
    UNLOCK_NOTIFIER_TSD;
    UNLOCK_NOTIFIER;
    UNLOCK_NOTIFIER_INIT;
#endif

    asyncPending = false;

    if (tsdPtr->runLoop) {
	tsdPtr->runLoop = NULL;
	tsdPtr->runLoopSource = NULL;
	tsdPtr->runLoopTimer = NULL;
    }
    if (notifierCount > 0) {
	notifierCount = 1;
	notifierThreadRunning = false;

	/*
	 * Restart the notifier thread for signal handling.
	 */

	StartNotifierThread();
    }
Changes to unix/tclEpollNotfy.c.
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#endif /* HAVE_EVENTFD */
    int eventsFd;		/* epoll(7) file descriptor used to wait for
				 * fds */
    struct epoll_event *readyEvents;
				/* Pointer to at most maxReadyEvents events
				 * returned by epoll_wait(2). */
    size_t maxReadyEvents;	/* Count of epoll_events in readyEvents. */
    int asyncPending;		/* True when signal triggered thread. */
};

static Tcl_ThreadDataKey dataKey;

/*
 * Forward declarations.
 */







|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#endif /* HAVE_EVENTFD */
    int eventsFd;		/* epoll(7) file descriptor used to wait for
				 * fds */
    struct epoll_event *readyEvents;
				/* Pointer to at most maxReadyEvents events
				 * returned by epoll_wait(2). */
    size_t maxReadyEvents;	/* Count of epoll_events in readyEvents. */
    bool asyncPending;		/* True when signal triggered thread. */
};

static Tcl_ThreadDataKey dataKey;

/*
 * Forward declarations.
 */
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
	    timersub(timePtr, &tv_delta, timePtr);
	} else {
	    timePtr->tv_sec = 0;
	    timePtr->tv_usec = 0;
	}
    }
    if (tsdPtr->asyncPending) {
	tsdPtr->asyncPending = 0;
	TclAsyncMarkFromNotifier();
    }
    return numFound;
}

/*
 *----------------------------------------------------------------------







|







481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
	    timersub(timePtr, &tv_delta, timePtr);
	} else {
	    timePtr->tv_sec = 0;
	    timePtr->tv_usec = 0;
	}
    }
    if (tsdPtr->asyncPending) {
	tsdPtr->asyncPending = false;
	TclAsyncMarkFromNotifier();
    }
    return numFound;
}

/*
 *----------------------------------------------------------------------
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
 *
 * Side effects:
 *	The signal may be resent to the target thread.
 *
 *----------------------------------------------------------------------
 */

int

TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    Tcl_ThreadId threadId,	/* Target thread. */
    void *clientData,		/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) threadId)) {
	ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

	*flagPtr = value;
	if (tsdPtr != NULL && !tsdPtr->asyncPending) {
	    tsdPtr->asyncPending = 1;
	    TclpAlertNotifier(tsdPtr);
	    return 1;
	}
	return 0;
    }

    /*
     * Re-send the signal to the proper target thread.
     */

    pthread_kill((pthread_t) threadId, sigNumber);
#else
    (void)sigNumber;
    (void)threadId;
    (void)clientData;
    (void)flagPtr;
    (void)value;
#endif
    return 0;
}

#endif /* NOTIFIER_EPOLL && TCL_THREADS */
#else
TCL_MAC_EMPTY_FILE(unix_tclEpollNotfy_c)
#endif /* !HAVE_COREFOUNDATION */








<
>




















|

|

|














|







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
 *
 * Side effects:
 *	The signal may be resent to the target thread.
 *
 *----------------------------------------------------------------------
 */


bool
TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    Tcl_ThreadId threadId,	/* Target thread. */
    void *clientData,		/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) threadId)) {
	ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

	*flagPtr = value;
	if (tsdPtr != NULL && !tsdPtr->asyncPending) {
	    tsdPtr->asyncPending = true;
	    TclpAlertNotifier(tsdPtr);
	    return true;
	}
	return false;
    }

    /*
     * Re-send the signal to the proper target thread.
     */

    pthread_kill((pthread_t) threadId, sigNumber);
#else
    (void)sigNumber;
    (void)threadId;
    (void)clientData;
    (void)flagPtr;
    (void)value;
#endif
    return false;
}

#endif /* NOTIFIER_EPOLL && TCL_THREADS */
#else
TCL_MAC_EMPTY_FILE(unix_tclEpollNotfy_c)
#endif /* !HAVE_COREFOUNDATION */

Changes to unix/tclKqueueNotfy.c.
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    int triggerPipe[2];		/* pipe(2) used by other threads to wake
				 * up this thread for inter-thread IPC. */
    int eventsFd;		/* kqueue(2) file descriptor used to wait for
				 * fds. */
    struct kevent *readyEvents;	/* Pointer to at most maxReadyEvents events
				 * returned by kevent(2). */
    size_t maxReadyEvents;	/* Count of kevents in readyEvents. */
    int asyncPending;		/* True when signal triggered thread. */
};

static Tcl_ThreadDataKey dataKey;

/*
 * Forward declarations of internal functions.
 */







|







98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    int triggerPipe[2];		/* pipe(2) used by other threads to wake
				 * up this thread for inter-thread IPC. */
    int eventsFd;		/* kqueue(2) file descriptor used to wait for
				 * fds. */
    struct kevent *readyEvents;	/* Pointer to at most maxReadyEvents events
				 * returned by kevent(2). */
    size_t maxReadyEvents;	/* Count of kevents in readyEvents. */
    bool asyncPending;		/* True when signal triggered thread. */
};

static Tcl_ThreadDataKey dataKey;

/*
 * Forward declarations of internal functions.
 */
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
	    timersub(timePtr, &tv_delta, timePtr);
	} else {
	    timePtr->tv_sec = 0;
	    timePtr->tv_usec = 0;
	}
    }
    if (tsdPtr->asyncPending) {
	tsdPtr->asyncPending = 0;
	TclAsyncMarkFromNotifier();
    }
    return numFound;
}

/*
 *----------------------------------------------------------------------







|







480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
	    timersub(timePtr, &tv_delta, timePtr);
	} else {
	    timePtr->tv_sec = 0;
	    timePtr->tv_usec = 0;
	}
    }
    if (tsdPtr->asyncPending) {
	tsdPtr->asyncPending = false;
	TclAsyncMarkFromNotifier();
    }
    return numFound;
}

/*
 *----------------------------------------------------------------------
777
778
779
780
781
782
783
784

785
786
787
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
 *
 * Side effects:
 *	The signal may be resent to the target thread.
 *
 *----------------------------------------------------------------------
 */

int

TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    Tcl_ThreadId threadId,	/* Target thread. */
    void *clientData,		/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) threadId)) {
	ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

	*flagPtr = value;
	if (tsdPtr != NULL && !tsdPtr->asyncPending) {
	    tsdPtr->asyncPending = 1;
	    TclpAlertNotifier(tsdPtr);
	    return 1;
	}
	return 0;
    }

    /*
     * Re-send the signal to the proper target thread.
     */

    pthread_kill((pthread_t) threadId, sigNumber);
#else
    (void)sigNumber;
    (void)threadId;
    (void)clientData;
    (void)flagPtr;
    (void)value;
#endif
    return 0;
}

#endif /* NOTIFIER_KQUEUE && TCL_THREADS */
#else
TCL_MAC_EMPTY_FILE(unix_tclKqueueNotfy_c)
#endif /* !HAVE_COREFOUNDATION */








<
>




















|

|

|














|







777
778
779
780
781
782
783

784
785
786
787
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
 *
 * Side effects:
 *	The signal may be resent to the target thread.
 *
 *----------------------------------------------------------------------
 */


bool
TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    Tcl_ThreadId threadId,	/* Target thread. */
    void *clientData,		/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) threadId)) {
	ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;

	*flagPtr = value;
	if (tsdPtr != NULL && !tsdPtr->asyncPending) {
	    tsdPtr->asyncPending = true;
	    TclpAlertNotifier(tsdPtr);
	    return true;
	}
	return false;
    }

    /*
     * Re-send the signal to the proper target thread.
     */

    pthread_kill((pthread_t) threadId, sigNumber);
#else
    (void)sigNumber;
    (void)threadId;
    (void)clientData;
    (void)flagPtr;
    (void)value;
#endif
    return false;
}

#endif /* NOTIFIER_KQUEUE && TCL_THREADS */
#else
TCL_MAC_EMPTY_FILE(unix_tclKqueueNotfy_c)
#endif /* !HAVE_COREFOUNDATION */

Changes to unix/tclSelectNotfy.c.
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
#if TCL_THREADS
    int onList;			/* True if it is in this list */
    unsigned int pollState;	/* pollState is used to implement a polling
				 * handshake between each thread and the
				 * notifier thread. Bits defined below. */
    ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed







|







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
    SelectMasks readyMasks;	/* This array reflects the readable/writable
				 * conditions that were found to exist by the
				 * last call to select. */
    int numFdBits;		/* Number of valid bits in checkMasks (one
				 * more than highest fd for which
				 * Tcl_WatchFile has been called). */
#if TCL_THREADS
    bool onList;		/* True if it is in this list */
    unsigned int pollState;	/* pollState is used to implement a polling
				 * handshake between each thread and the
				 * notifier thread. Bits defined below. */
    ThreadSpecificData *nextPtr, *prevPtr;
				/* All threads that are currently waiting on
				 * an event have their ThreadSpecificData
				 * structure on a doubly-linked listed formed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
static pthread_mutex_t notifierMutex     = PTHREAD_MUTEX_INITIALIZER;
/*
 * The following static indicates if the notifier thread is running.
 *
 * You must hold the notifierInitMutex before accessing this variable.
 */

static int notifierThreadRunning = 0;

/*
 * The following static flag indicates that async handlers are pending.
 */

static int asyncPending = 0;

/*
 * The notifier thread signals the notifierCV when it has finished
 * initializing the triggerPipe and right before the notifier thread
 * terminates. This condition is used to deal with the signal mask, too.
 */








|





|







159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
static pthread_mutex_t notifierMutex     = PTHREAD_MUTEX_INITIALIZER;
/*
 * The following static indicates if the notifier thread is running.
 *
 * You must hold the notifierInitMutex before accessing this variable.
 */

static bool notifierThreadRunning = false;

/*
 * The following static flag indicates that async handlers are pending.
 */

static bool asyncPending = false;

/*
 * The notifier thread signals the notifierCV when it has finished
 * initializing the triggerPipe and right before the notifier thread
 * terminates. This condition is used to deal with the signal mask, too.
 */

213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
/*
 * Static routines defined in this file.
 */

#if TCL_THREADS
static TCL_NORETURN void NotifierThreadProc(void *clientData);
#if defined(HAVE_PTHREAD_ATFORK)
static int atForkInit = 0;
static void		AtForkChild(void);
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);

/*
 * Import of critical bits of Windows API when building threaded with Cygwin.







|







213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
/*
 * Static routines defined in this file.
 */

#if TCL_THREADS
static TCL_NORETURN void NotifierThreadProc(void *clientData);
#if defined(HAVE_PTHREAD_ATFORK)
static int atForkInit = false;
static void		AtForkChild(void);
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* TCL_THREADS */
static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);

/*
 * Import of critical bits of Windows API when building threaded with Cygwin.
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376

    if (!atForkInit) {
	int result = pthread_atfork(NULL, NULL, AtForkChild);

	if (result) {
	    Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
	}
	atForkInit = 1;
    }
#endif /* HAVE_PTHREAD_ATFORK */

    notifierCount++;
    pthread_mutex_unlock(&notifierInitMutex);
#endif /* TCL_THREADS */








|







362
363
364
365
366
367
368
369
370
371
372
373
374
375
376

    if (!atForkInit) {
	int result = pthread_atfork(NULL, NULL, AtForkChild);

	if (result) {
	    Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
	}
	atForkInit = true;
    }
#endif /* HAVE_PTHREAD_ATFORK */

    notifierCount++;
    pthread_mutex_unlock(&notifierInitMutex);
#endif /* TCL_THREADS */

424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
	if (notifierThreadRunning) {
	    int result = pthread_join((pthread_t) notifierThread, NULL);

	    if (result) {
		Tcl_Panic("Tcl_FinalizeNotifier: %s",
			"unable to join notifier thread");
	    }
	    notifierThreadRunning = 0;

	    /*
	     * If async marks are outstanding, perform actions now.
	     */
	    if (asyncPending) {
		asyncPending = 0;
		TclAsyncMarkFromNotifier();
	    }
	}
    }

    /*
     * Clean up any synchronization objects in the thread local storage.







|





|







424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
	if (notifierThreadRunning) {
	    int result = pthread_join((pthread_t) notifierThread, NULL);

	    if (result) {
		Tcl_Panic("Tcl_FinalizeNotifier: %s",
			"unable to join notifier thread");
	    }
	    notifierThreadRunning = false;

	    /*
	     * If async marks are outstanding, perform actions now.
	     */
	    if (asyncPending) {
		asyncPending = false;
		TclAsyncMarkFromNotifier();
	    }
	}
    }

    /*
     * Clean up any synchronization objects in the thread local storage.
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763

	tsdPtr->nextPtr = waitingListPtr;
	if (waitingListPtr) {
	    waitingListPtr->prevPtr = tsdPtr;
	}
	tsdPtr->prevPtr = 0;
	waitingListPtr = tsdPtr;
	tsdPtr->onList = 1;

	if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
	    Tcl_Panic("Tcl_WaitForEvent: %s",
		    "unable to write to triggerPipe");
	}
    }








|







749
750
751
752
753
754
755
756
757
758
759
760
761
762
763

	tsdPtr->nextPtr = waitingListPtr;
	if (waitingListPtr) {
	    waitingListPtr->prevPtr = tsdPtr;
	}
	tsdPtr->prevPtr = 0;
	waitingListPtr = tsdPtr;
	tsdPtr->onList = true;

	if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
	    Tcl_Panic("Tcl_WaitForEvent: %s",
		    "unable to write to triggerPipe");
	}
    }

832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
	    Tcl_Panic("Tcl_WaitForEvent: %s",
		    "unable to write to triggerPipe");
	}
    }
#else /* !TCL_THREADS */
    tsdPtr->readyMasks = tsdPtr->checkMasks;







|







832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = false;
	if ((write(triggerPipe, "", 1) == -1) && (errno != EAGAIN)) {
	    Tcl_Panic("Tcl_WaitForEvent: %s",
		    "unable to write to triggerPipe");
	}
    }
#else /* !TCL_THREADS */
    tsdPtr->readyMasks = tsdPtr->checkMasks;
916
917
918
919
920
921
922
923

924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
 * Side effetcs:
 *	The trigger pipe is written when called from the notifier
 *	thread.
 *
 *----------------------------------------------------------------------
 */

int

TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),	/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) notifierThread)) {
	if (notifierThreadRunning) {
	    *flagPtr = value;
	    if (!asyncPending) {
		asyncPending = 1;
		if (write(triggerPipe, "S", 1) != 1) {
		    asyncPending = 0;
		    return 0;
		};
	    }
	    return 1;
	}
	return 0;
    }

    /*
     * Re-send the signal to the notifier thread.
     */

    pthread_kill((pthread_t) notifierThread, sigNumber);
#else
    (void)sigNumber;
    (void)flagPtr;
    (void)value;
#endif
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *







<
>



















|

|
|


|

|












|







916
917
918
919
920
921
922

923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
 * Side effetcs:
 *	The trigger pipe is written when called from the notifier
 *	thread.
 *
 *----------------------------------------------------------------------
 */


bool
TclAsyncNotifier(
    int sigNumber,		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),	/* Notifier data. */
    int *flagPtr,		/* Flag to mark. */
    int value)			/* Value of mark. */
{
#if TCL_THREADS
    /*
     * WARNING:
     * This code most likely runs in a signal handler. Thus,
     * only few async-signal-safe system calls are allowed,
     * e.g. pthread_self(), sem_post(), write().
     */

    if (pthread_equal(pthread_self(), (pthread_t) notifierThread)) {
	if (notifierThreadRunning) {
	    *flagPtr = value;
	    if (!asyncPending) {
		asyncPending = true;
		if (write(triggerPipe, "S", 1) != 1) {
		    asyncPending = false;
		    return false;
		};
	    }
	    return true;
	}
	return false;
    }

    /*
     * Re-send the signal to the notifier thread.
     */

    pthread_kill((pthread_t) notifierThread, sigNumber);
#else
    (void)sigNumber;
    (void)flagPtr;
    (void)value;
#endif
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierThreadProc --
 *
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143

	if (ret == -1) {
	    /*
	     * In case a signal was caught during select(),
	     * perform work on async handlers now.
	     */
	    if (errno == EINTR && asyncPending) {
		asyncPending = 0;
		TclAsyncMarkFromNotifier();
	    }

	    /*
	     * Try again immediately on select() error.
	     */
	    continue;







|







1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143

	if (ret == -1) {
	    /*
	     * In case a signal was caught during select(),
	     * perform work on async handlers now.
	     */
	    if (errno == EINTR && asyncPending) {
		asyncPending = false;
		TclAsyncMarkFromNotifier();
	    }

	    /*
	     * Try again immediately on select() error.
	     */
	    continue;
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
		 */

		break;
	    }
	} while (1);

	if (asyncPending) {
	    asyncPending = 0;
	    TclAsyncMarkFromNotifier();
	}

	if ((i == 0) || (buf[0] == 'q')) {
	    break;
	}
    }







|







1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
		 */

		break;
	    }
	} while (1);

	if (asyncPending) {
	    asyncPending = false;
	    TclAsyncMarkFromNotifier();
	}

	if ((i == 0) || (buf[0] == 'q')) {
	    break;
	}
    }
Changes to unix/tclUnixChan.c.
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
FileGetOptionProc(
    void *instanceData,
    Tcl_Interp *interp,
    const char *optionName,
    Tcl_DString *dsPtr)
{
    FileState *fsPtr = (FileState *)instanceData;
    int valid = 0;		/* Flag if valid option parsed. */
    size_t len;

    if (optionName == NULL) {
	len = 0;
	valid = 1;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not







|




|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
FileGetOptionProc(
    void *instanceData,
    Tcl_Interp *interp,
    const char *optionName,
    Tcl_DString *dsPtr)
{
    FileState *fsPtr = (FileState *)instanceData;
    bool valid = false;		/* Flag if valid option parsed. */
    size_t len;

    if (optionName == NULL) {
	len = 0;
	valid = true;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len;
    char buf[3*TCL_INTEGER_SPACE + 16];
    int valid = 0;		/* Flag if valid option parsed. */
    struct termios iostate;

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }







|







1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    TtyState *fsPtr = (TtyState *)instanceData;
    size_t len;
    char buf[3*TCL_INTEGER_SPACE + 16];
    bool valid = false;		/* Flag if valid option parsed. */
    struct termios iostate;

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
     * represents what almost all scripts really want to know.
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-inputmode");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
	valid = 1;
	if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
	    if (interp != NULL) {
		TclPrintfResult(interp,
			"couldn't read serial terminal control state: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;







|







1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
     * represents what almost all scripts really want to know.
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-inputmode");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
	valid = true;
	if (tcgetattr(fsPtr->fileState.fd, &iostate) < 0) {
	    if (interp != NULL) {
		TclPrintfResult(interp,
			"couldn't read serial terminal control state: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
1169
1170
1171
1172
1173
1174
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

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-mode");
    }
    if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) {
	TtyAttrs tty;

	valid = 1;
	TtyGetAttributes(fsPtr->fileState.fd, &tty);
	snprintf(buf, sizeof(buf), "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
	Tcl_DString ds;

	valid = 1;
	tcgetattr(fsPtr->fileState.fd, &iostate);
	Tcl_DStringInit(&ds);

	Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTART],
		1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
	Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
	TclDStringClear(&ds);







|
















|







1169
1170
1171
1172
1173
1174
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

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-mode");
    }
    if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) {
	TtyAttrs tty;

	valid = true;
	TtyGetAttributes(fsPtr->fileState.fd, &tty);
	snprintf(buf, sizeof(buf), "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
	Tcl_DString ds;

	valid = true;
	tcgetattr(fsPtr->fileState.fd, &iostate);
	Tcl_DStringInit(&ds);

	Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTART],
		1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
	Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
	TclDStringClear(&ds);
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
     * Option is readonly and returned by [fconfigure chan -queue] but not
     * returned by unnamed [fconfigure chan].
     */

    if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
	int inQueue=0, outQueue=0, inBuffered, outBuffered;

	valid = 1;
	GETREADQUEUE(fsPtr->fileState.fd, inQueue);
	GETWRITEQUEUE(fsPtr->fileState.fd, outQueue);
	inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel);
	outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel);

	snprintf(buf, sizeof(buf), "%d", inBuffered+inQueue);
	Tcl_DStringAppendElement(dsPtr, buf);







|







1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
     * Option is readonly and returned by [fconfigure chan -queue] but not
     * returned by unnamed [fconfigure chan].
     */

    if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
	int inQueue=0, outQueue=0, inBuffered, outBuffered;

	valid = true;
	GETREADQUEUE(fsPtr->fileState.fd, inQueue);
	GETWRITEQUEUE(fsPtr->fileState.fd, outQueue);
	inBuffered = Tcl_InputBuffered(fsPtr->fileState.channel);
	outBuffered = Tcl_OutputBuffered(fsPtr->fileState.channel);

	snprintf(buf, sizeof(buf), "%d", inBuffered+inQueue);
	Tcl_DStringAppendElement(dsPtr, buf);
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
     * Option is readonly and returned by [fconfigure chan -ttystatus] but not
     * returned by unnamed [fconfigure chan].
     */

    if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
	int status;

	valid = 1;
	ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
	TtyModemStatusStr(status, dsPtr);
    }
#endif /* TIOCMGET */

#if defined(TIOCGWINSZ)
    /*
     * Get option -winsize
     * Option is readonly and returned by [fconfigure chan -winsize] but not
     * returned by [fconfigure chan] without explicit option name.
     */

    if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
	struct winsize ws;

	valid = 1;
	if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) {
	    if (interp != NULL) {
		TclPrintfResult(interp, "couldn't read terminal size: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}







|















|







1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
     * Option is readonly and returned by [fconfigure chan -ttystatus] but not
     * returned by unnamed [fconfigure chan].
     */

    if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
	int status;

	valid = true;
	ioctl(fsPtr->fileState.fd, TIOCMGET, &status);
	TtyModemStatusStr(status, dsPtr);
    }
#endif /* TIOCMGET */

#if defined(TIOCGWINSZ)
    /*
     * Get option -winsize
     * Option is readonly and returned by [fconfigure chan -winsize] but not
     * returned by [fconfigure chan] without explicit option name.
     */

    if ((len > 1) && (strncmp(optionName, "-winsize", len) == 0)) {
	struct winsize ws;

	valid = true;
	if (ioctl(fsPtr->fileState.fd, TIOCGWINSZ, &ws) < 0) {
	    if (interp != NULL) {
		TclPrintfResult(interp, "couldn't read terminal size: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}
Changes to unix/tclUnixInit.c.
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
void
TclpSetVariables(
    Tcl_Interp *interp)
{
#ifdef __CYGWIN__
    SYSTEM_INFO sysInfo;
    static OSVERSIONINFOW osInfo;
    static int osInfoInitialized = 0;
    char buffer[TCL_INTEGER_SPACE * 2];
#elif !defined(NO_UNAME)
    struct utsname name;
#endif
    int unameOK;
    const char *p, *q;
    Tcl_Obj *pkgListObj = Tcl_NewObj();







|







759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
void
TclpSetVariables(
    Tcl_Interp *interp)
{
#ifdef __CYGWIN__
    SYSTEM_INFO sysInfo;
    static OSVERSIONINFOW osInfo;
    static bool osInfoInitialized = false;
    char buffer[TCL_INTEGER_SPACE * 2];
#elif !defined(NO_UNAME)
    struct utsname name;
#endif
    int unameOK;
    const char *p, *q;
    Tcl_Obj *pkgListObj = Tcl_NewObj();
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
	void *handle = GetModuleHandleW(L"NTDLL");
	int(__stdcall *getversion)(void *) =
		(int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion");
	osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
	if (!getversion || getversion(&osInfo)) {
	    GetVersionExW(&osInfo);
	}
	osInfoInitialized = 1;
    }

    GetSystemInfo(&sysInfo);

    if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
	osInfo.dwMajorVersion = 11;
    }







|







862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
	void *handle = GetModuleHandleW(L"NTDLL");
	int(__stdcall *getversion)(void *) =
		(int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion");
	osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
	if (!getversion || getversion(&osInfo)) {
	    GetVersionExW(&osInfo);
	}
	osInfoInitialized = true;
    }

    GetSystemInfo(&sysInfo);

    if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
	osInfo.dwMajorVersion = 11;
    }
Changes to unix/tclUnixNotfy.c.
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
	     */

	    while (triggerPipe < 0) {
		pthread_cond_wait(&notifierCV, &notifierMutex);
	    }
	    pthread_mutex_unlock(&notifierMutex);

	    notifierThreadRunning = 1;
	}
	pthread_mutex_unlock(&notifierInitMutex);
    }
}
#endif /* NOTIFIER_SELECT */

/*







|







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
	     */

	    while (triggerPipe < 0) {
		pthread_cond_wait(&notifierCV, &notifierMutex);
	    }
	    pthread_mutex_unlock(&notifierMutex);

	    notifierThreadRunning = true;
	}
	pthread_mutex_unlock(&notifierInitMutex);
    }
}
#endif /* NOTIFIER_SELECT */

/*
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.







|







282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
{
    int mask;
    FileHandler *filePtr;
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
    ThreadSpecificData *tsdPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    filePtr->proc(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

#ifdef NOTIFIER_SELECT
#if TCL_THREADS
/*
 *----------------------------------------------------------------------
 *







|







319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
	mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    filePtr->proc(filePtr->clientData, mask);
	}
	break;
    }
    return true;
}

#ifdef NOTIFIER_SELECT
#if TCL_THREADS
/*
 *----------------------------------------------------------------------
 *
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = 0;
	tsdPtr->pollState = 0;
    }
#ifdef __CYGWIN__
    PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#else /* !__CYGWIN__ */
    pthread_cond_broadcast(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */







|







364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
	} else {
	    waitingListPtr = tsdPtr->nextPtr;
	}
	if (tsdPtr->nextPtr) {
	    tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
	}
	tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
	tsdPtr->onList = false;
	tsdPtr->pollState = 0;
    }
#ifdef __CYGWIN__
    PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
#else /* !__CYGWIN__ */
    pthread_cond_broadcast(&tsdPtr->waitCV);
#endif /* __CYGWIN__ */
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
 *
 *----------------------------------------------------------------------
 */

static void
AtForkChild(void)
{
    if (notifierThreadRunning == 1) {
	pthread_cond_destroy(&notifierCV);
    }
    pthread_mutex_init(&notifierInitMutex, NULL);
    pthread_mutex_init(&notifierMutex, NULL);
    pthread_cond_init(&notifierCV, NULL);

#ifdef NOTIFIER_SELECT
    asyncPending = 0;
#endif

    /*
     * notifierThreadRunning == 1: thread is running, (there might be data in
     *		notifier lists)
     * atForkInit == 0: InitNotifier was never called
     * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
     * waitingListPtr != 0: there are threads currently waiting for events.
     */

    if (atForkInit == 1) {

	notifierCount = 0;
	if (notifierThreadRunning == 1) {
	    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	    notifierThreadRunning = 0;

	    close(triggerPipe);
	    triggerPipe = -1;
#ifdef NOTIFIER_SELECT
	    close(otherPipe);
	    otherPipe = -1;
#endif







|







|



|
|
|




|


|

|







394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
 *
 *----------------------------------------------------------------------
 */

static void
AtForkChild(void)
{
    if (notifierThreadRunning) {
	pthread_cond_destroy(&notifierCV);
    }
    pthread_mutex_init(&notifierInitMutex, NULL);
    pthread_mutex_init(&notifierMutex, NULL);
    pthread_cond_init(&notifierCV, NULL);

#ifdef NOTIFIER_SELECT
    asyncPending = false;
#endif

    /*
     * notifierThreadRunning == true: thread is running, (there might be data
     *		in notifier lists)
     * atForkInit == false: InitNotifier was never called
     * notifierCount != 0: unbalanced InitNotifier() / FinalizeNotifier calls
     * waitingListPtr != 0: there are threads currently waiting for events.
     */

    if (atForkInit) {

	notifierCount = 0;
	if (notifierThreadRunning) {
	    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
	    notifierThreadRunning = false;

	    close(triggerPipe);
	    triggerPipe = -1;
#ifdef NOTIFIER_SELECT
	    close(otherPipe);
	    otherPipe = -1;
#endif
Changes to unix/tclUnixSock.c.
678
679
680
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
 */

#ifndef NEED_FAKE_RFC2553
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline int
IPv6AddressNeedsNumericRendering(
    struct in6_addr addr)
{
    if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
	return 1;
    }

    /*
     * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on
     * at least some versions of OSX.
     */

    if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
	return 0;
    }

    return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
	    && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop







|




|








|







678
679
680
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
 */

#ifndef NEED_FAKE_RFC2553
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wstrict-aliasing"
#endif
static inline bool
IPv6AddressNeedsNumericRendering(
    struct in6_addr addr)
{
    if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) {
	return true;
    }

    /*
     * The IN6_IS_ADDR_V4MAPPED macro has a problem with aliasing warnings on
     * at least some versions of OSX.
     */

    if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
	return false;
    }

    return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
	    && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
#if defined (__clang__) || ((__GNUC__)  && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5))))
#pragma GCC diagnostic pop
Changes to unix/tclUnixTest.c.
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
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Argument strings. */
{
    Pipe *pipePtr;
    int mask, timeout;
    static int initialized = 0;
    char buffer[4000];
    TclFile file;

    /*
     * NOTE: When we make this code work on Windows also, the following
     * variable needs to be made Unix-only.
     */

    if (!initialized) {
	for (int i = 0; i < MAX_PIPES; i++) {
	    testPipes[i].readFile = NULL;
	}
	initialized = 1;
    }

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ...");
	return TCL_ERROR;
    }
    pipePtr = NULL;







|












|







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
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Argument strings. */
{
    Pipe *pipePtr;
    int mask, timeout;
    static bool initialized = false;
    char buffer[4000];
    TclFile file;

    /*
     * NOTE: When we make this code work on Windows also, the following
     * variable needs to be made Unix-only.
     */

    if (!initialized) {
	for (int i = 0; i < MAX_PIPES; i++) {
	    testPipes[i].readFile = NULL;
	}
	initialized = true;
    }

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ...");
	return TCL_ERROR;
    }
    pipePtr = NULL;
Changes to unix/tclUnixTime.c.
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
double
TclpWideClickInMicrosec(void)
{
    if (!IsTimeNative()) {
	return 1.0;
    } else {
#ifdef MAC_OSX_TCL
	static int initialized = 0;
	static double scale = 0.0;

	if (!initialized) {
	    mach_timebase_info_data_t tb;

	    mach_timebase_info(&tb);
	    /* value of tb.numer / tb.denom = 1 click in nanoseconds */
	    scale = ((double) tb.numer) / tb.denom / 1000;
	    initialized = 1;
	}
	return scale;
#else
#error Wide high-resolution clicks not implemented on this platform
#endif /* MAC_OSX_TCL */
    }
}







|








|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
double
TclpWideClickInMicrosec(void)
{
    if (!IsTimeNative()) {
	return 1.0;
    } else {
#ifdef MAC_OSX_TCL
	static bool initialized = false;
	static double scale = 0.0;

	if (!initialized) {
	    mach_timebase_info_data_t tb;

	    mach_timebase_info(&tb);
	    /* value of tb.numer / tb.denom = 1 click in nanoseconds */
	    scale = ((double) tb.numer) / tb.denom / 1000;
	    initialized = true;
	}
	return scale;
#else
#error Wide high-resolution clicks not implemented on this platform
#endif /* MAC_OSX_TCL */
    }
}
Changes to unix/tclXtNotify.c.
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
				/* Pointer to head of file handler list. */
} notifier;

/*
 * The following static indicates whether this module has been initialized.
 */

static int initialized = 0;

/*
 * Static routines defined in this file.
 */

static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);
static void		FileProc(XtPointer clientData, int *source,







|







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
				/* Pointer to head of file handler list. */
} notifier;

/*
 * The following static indicates whether this module has been initialized.
 */

static bool initialized = false;

/*
 * Static routines defined in this file.
 */

static int		FileHandlerEventProc(Tcl_Event *evPtr, int flags);
static void		FileProc(XtPointer clientData, int *source,
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
    Tcl_SetNotifier(&np);

    /*
     * DO NOT create the application context yet; doing so would prevent
     * external applications from setting it for us to their own ones.
     */

    initialized = 1;
    Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierExitHandler --







|







202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
    Tcl_SetNotifier(&np);

    /*
     * DO NOT create the application context yet; doing so would prevent
     * external applications from setting it for us to their own ones.
     */

    initialized = true;
    Tcl_CreateExitHandler(NotifierExitHandler, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierExitHandler --
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
	Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
    }
    if (notifier.appContextCreated) {
	XtDestroyApplicationContext(notifier.appContext);
	notifier.appContextCreated = 0;
	notifier.appContext = NULL;
    }
    initialized = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * SetTimer --
 *







|







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
	Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
    }
    if (notifier.appContextCreated) {
	XtDestroyApplicationContext(notifier.appContext);
	notifier.appContextCreated = 0;
	notifier.appContext = NULL;
    }
    initialized = false;
}

/*
 *----------------------------------------------------------------------
 *
 * SetTimer --
 *
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    Tcl_Event *evPtr,		/* Event to service. */
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.







|







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    Tcl_Event *evPtr,		/* Event to service. */
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the file handlers to find the one whose handle matches
     * the event. We do this rather than keeping a pointer to the file handler
     * directly in the event, so that the handler can be deleted while the
     * event is queued without leaving a dangling pointer.
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
	int mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    filePtr->proc(filePtr->clientData, mask);
	}
	break;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForEvent --
 *







|







596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
	int mask = filePtr->readyMask & filePtr->mask;
	filePtr->readyMask = 0;
	if (mask != 0) {
	    filePtr->proc(filePtr->clientData, mask);
	}
	break;
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * WaitForEvent --
 *
Changes to win/tclAppInit.c.
257
258
259
260
261
262
263
264

265
266
267
268
269
270
271
static void
setargv(
    int *argcPtr,		/* Filled with number of argument strings. */
    TCHAR ***argvPtr)		/* Filled with argument strings (malloc'd). */
{
    TCHAR *cmdLine, *p, *arg, *argSpace;
    TCHAR **argv;
    int argc, size, inquote, copy, slashes;


    cmdLine = GetCommandLine();

    /*
     * Precompute an overly pessimistic guess at the number of arguments in
     * the command line by counting non-space spans.
     */







|
>







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
static void
setargv(
    int *argcPtr,		/* Filled with number of argument strings. */
    TCHAR ***argvPtr)		/* Filled with argument strings (malloc'd). */
{
    TCHAR *cmdLine, *p, *arg, *argSpace;
    TCHAR **argv;
    int argc, size, slashes;
    bool copy, inquote;

    cmdLine = GetCommandLine();

    /*
     * Precompute an overly pessimistic guess at the number of arguments in
     * the command line by counting non-space spans.
     */
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
	while ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
	    p++;
	}
	if (*p == '\0') {
	    break;
	}

	inquote = 0;
	slashes = 0;
	while (1) {
	    copy = 1;
	    while (*p == '\\') {
		slashes++;
		p++;
	    }
	    if (*p == '"') {
		if ((slashes & 1) == 0) {
		    copy = 0;
		    if ((inquote) && (p[1] == '"')) {
			p++;
			copy = 1;
		    } else {
			inquote = !inquote;
		    }
		}
		slashes >>= 1;
	    }

	    while (slashes) {
		*arg = '\\';
		arg++;
		slashes--;
	    }

	    if ((*p == '\0') || (!inquote &&
		    ((*p == ' ') || (*p == '\t')))) {	/* INTL: ISO space. */
		break;
	    }
	    if (copy != 0) {
		*arg = *p;
		arg++;
	    }
	    p++;
	}
	*arg = '\0';
	argSpace = arg + 1;







|


|






|
|

|

















|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
	while ((*p == ' ') || (*p == '\t')) {	/* INTL: ISO space. */
	    p++;
	}
	if (*p == '\0') {
	    break;
	}

	inquote = false;
	slashes = 0;
	while (1) {
	    copy = true;
	    while (*p == '\\') {
		slashes++;
		p++;
	    }
	    if (*p == '"') {
		if ((slashes & 1) == 0) {
		    copy = false;
		    if (inquote && (p[1] == '"')) {
			p++;
			copy = true;
		    } else {
			inquote = !inquote;
		    }
		}
		slashes >>= 1;
	    }

	    while (slashes) {
		*arg = '\\';
		arg++;
		slashes--;
	    }

	    if ((*p == '\0') || (!inquote &&
		    ((*p == ' ') || (*p == '\t')))) {	/* INTL: ISO space. */
		break;
	    }
	    if (copy) {
		*arg = *p;
		arg++;
	    }
	    p++;
	}
	*arg = '\0';
	argSpace = arg + 1;
Changes to win/tclWin32Dll.c.
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
    for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) {
	/*
	 * Try to read the volume mount point and see where it points.
	 */

	if (GetVolumeNameForVolumeMountPointW(drive,
		Target, 55) != 0) {
	    int alreadyStored = 0;

	    for (dlIter = driveLetterLookup; dlIter != NULL;
		    dlIter = dlIter->nextPtr) {
		if (wcscmp(dlIter->volumeName, Target) == 0) {
		    alreadyStored = 1;
		    break;
		}
	    }
	    if (!alreadyStored) {
		dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap));
		dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target);
		dlPtr2->driveLetter = (WCHAR) drive[0];







|




|







363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
    for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) {
	/*
	 * Try to read the volume mount point and see where it points.
	 */

	if (GetVolumeNameForVolumeMountPointW(drive,
		Target, 55) != 0) {
	    bool alreadyStored = false;

	    for (dlIter = driveLetterLookup; dlIter != NULL;
		    dlIter = dlIter->nextPtr) {
		if (wcscmp(dlIter->volumeName, Target) == 0) {
		    alreadyStored = true;
		    break;
		}
	    }
	    if (!alreadyStored) {
		dlPtr2 = (MountPointMap *)Tcl_Alloc(sizeof(MountPointMap));
		dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target);
		dlPtr2->driveLetter = (WCHAR) drive[0];
Changes to win/tclWinChan.c.
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    HANDLE handle;		/* Input/output file. */
    struct FileInfo *nextPtr;	/* Pointer to next registered file. */
    int dirty;			/* Boolean flag. Set if the OS may have data
				 * pending on the channel. */
} FileInfo;

typedef struct ThreadSpecificData_WindowsChannels {
    /*
     * List of all file channels currently open.
     */







|







40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    HANDLE handle;		/* Input/output file. */
    struct FileInfo *nextPtr;	/* Pointer to next registered file. */
    bool dirty;			/* Boolean flag. Set if the OS may have data
				 * pending on the channel. */
} FileInfo;

typedef struct ThreadSpecificData_WindowsChannels {
    /*
     * List of all file channels currently open.
     */
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
static void		FileSetupProc(void *clientData, int flags);
static void		FileWatchProc(void *instanceData, int mask);
static void		FileThreadActionProc(void *instanceData,
			    int action);
static int		FileTruncateProc(void *instanceData,
			    long long length);
static DWORD		FileGetType(HANDLE handle);
static int		NativeIsComPort(const WCHAR *nativeName);
static Tcl_Channel	OpenFileChannel(HANDLE handle, char *channelName,
			    int permissions, int appendMode);

/*
 * This structure describes the channel type structure for file based IO.
 */








|







97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
static void		FileSetupProc(void *clientData, int flags);
static void		FileWatchProc(void *instanceData, int mask);
static void		FileThreadActionProc(void *instanceData,
			    int action);
static int		FileTruncateProc(void *instanceData,
			    long long length);
static DWORD		FileGetType(HANDLE handle);
static bool		NativeIsComPort(const WCHAR *nativeName);
static Tcl_Channel	OpenFileChannel(HANDLE handle, char *channelName,
			    int permissions, int appendMode);

/*
 * This structure describes the channel type structure for file based IO.
 */

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileEvent *fileEvPtr = (FileEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched files for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that files can be deleted while the event is in
     * the queue.
     */

    for (FileInfo *infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (fileEvPtr->infoPtr == infoPtr) {
	    CLEAR_FLAG(infoPtr->flags, FILE_PENDING);
	    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
	    break;
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * FileBlockProc --
 *







|

















|







341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    FileEvent *fileEvPtr = (FileEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the list of watched files for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that files can be deleted while the event is in
     * the queue.
     */

    for (FileInfo *infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (fileEvPtr->infoPtr == infoPtr) {
	    CLEAR_FLAG(infoPtr->flags, FILE_PENDING);
	    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
	    break;
	}
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * FileBlockProc --
 *
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717

    if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
	    &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
	Tcl_WinConvertError(GetLastError());
	*errorCode = errno;
	return -1;
    }
    infoPtr->dirty = 1;
    return (int)bytesWritten;
}

/*
 *----------------------------------------------------------------------
 *
 * FileWatchProc --







|







703
704
705
706
707
708
709
710
711
712
713
714
715
716
717

    if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
	    &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
	Tcl_WinConvertError(GetLastError());
	*errorCode = errno;
	return -1;
    }
    infoPtr->dirty = true;
    return (int)bytesWritten;
}

/*
 *----------------------------------------------------------------------
 *
 * FileWatchProc --
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
FileGetOptionProc(
    void *instanceData,		/* The file state. */
    Tcl_Interp *interp,		/* For error reporting. */
    const char *optionName,	/* What option to read, or NULL for all. */
    Tcl_DString *dsPtr)		/* Where to write the value read. */
{
    FileInfo *infoPtr = (FileInfo *)instanceData;
    int valid = 0;		/* Flag if valid option parsed. */
    size_t len;

    if (optionName == NULL) {
	len = 0;
	valid = 1;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not







|




|







905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
FileGetOptionProc(
    void *instanceData,		/* The file state. */
    Tcl_Interp *interp,		/* For error reporting. */
    const char *optionName,	/* What option to read, or NULL for all. */
    Tcl_DString *dsPtr)		/* Where to write the value read. */
{
    FileInfo *infoPtr = (FileInfo *)instanceData;
    bool valid = false;		/* Flag if valid option parsed. */
    size_t len;

    if (optionName == NULL) {
	len = 0;
	valid = true;
    } else {
	len = strlen(optionName);
    }

    /*
     * Get option -stat
     * Option is readonly and returned by [fconfigure chan -stat] but not
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226

Tcl_Channel
Tcl_MakeFileChannel(
    void *rawHandle,		/* OS level handle */
    int mode)			/* OR'ed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
    TCLEXCEPTION_REGISTRATION registration;
#endif
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;
    HANDLE handle = (HANDLE) rawHandle;
    HANDLE dupedHandle;
    TclFile readFile = NULL, writeFile = NULL;
    BOOL result;

    if ((mode & (TCL_READABLE|TCL_WRITABLE)) == 0) {
	return NULL;
    }

    switch (FileGetType(handle)) {
    case FILE_TYPE_SERIAL:







<
<
<





<







1204
1205
1206
1207
1208
1209
1210



1211
1212
1213
1214
1215

1216
1217
1218
1219
1220
1221
1222

Tcl_Channel
Tcl_MakeFileChannel(
    void *rawHandle,		/* OS level handle */
    int mode)			/* OR'ed combination of TCL_READABLE and
				 * TCL_WRITABLE to indicate file mode. */
{



    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_Channel channel = NULL;
    HANDLE handle = (HANDLE) rawHandle;
    HANDLE dupedHandle;
    TclFile readFile = NULL, writeFile = NULL;


    if ((mode & (TCL_READABLE|TCL_WRITABLE)) == 0) {
	return NULL;
    }

    switch (FileGetType(handle)) {
    case FILE_TYPE_SERIAL:
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285

1286
1287
1288
1289
1290
1291
1292
	 * handle by duplicating it, then closing the dupe. The Win32 API
	 * doesn't provide an IsValidHandle() function, so we have to emulate
	 * it here. This test will not work on a console handle reliably,
	 * which is why we can't test every handle that comes into this
	 * function in this way.
	 */

	result = DuplicateHandle(GetCurrentProcess(), handle,
		GetCurrentProcess(), &dupedHandle, 0, FALSE,
		DUPLICATE_SAME_ACCESS);

	if (result == 0) {
	    /*
	     * Unable to make a duplicate. It's definitely invalid at this
	     * point.
	     */

	    return NULL;
	}

	/*
	 * Use structured exception handling (Win32 SEH) to protect the close
	 * of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
	 */

	result = 0;
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
	/*
	 * Don't have SEH available, do things the hard way. Note that this
	 * needs to be one block of asm, to avoid stack imbalance; also, it is
	 * illegal for one asm block to contain a jump to another.
	 */

	__asm__ __volatile__ (


	    /*
	     * Pick up parameters before messing with the stack
	     */

	    "movl       %[dupedHandle], %%ebx"          "\n\t"

	    /*







|



|













|







|

>







1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
	 * handle by duplicating it, then closing the dupe. The Win32 API
	 * doesn't provide an IsValidHandle() function, so we have to emulate
	 * it here. This test will not work on a console handle reliably,
	 * which is why we can't test every handle that comes into this
	 * function in this way.
	 */

	BOOL result = DuplicateHandle(GetCurrentProcess(), handle,
		GetCurrentProcess(), &dupedHandle, 0, FALSE,
		DUPLICATE_SAME_ACCESS);

	if (result == FALSE) {
	    /*
	     * Unable to make a duplicate. It's definitely invalid at this
	     * point.
	     */

	    return NULL;
	}

	/*
	 * Use structured exception handling (Win32 SEH) to protect the close
	 * of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
	 */

	result = FALSE;
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
	/*
	 * Don't have SEH available, do things the hard way. Note that this
	 * needs to be one block of asm, to avoid stack imbalance; also, it is
	 * illegal for one asm block to contain a jump to another.
	 */

	TCLEXCEPTION_REGISTRATION registration;

	__asm__ __volatile__ (
	    /*
	     * Pick up parameters before messing with the stack
	     */

	    "movl       %[dupedHandle], %%ebx"          "\n\t"

	    /*
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
	    );
	result = registration.status;
#else
#ifndef HAVE_NO_SEH
	__try {
#endif
	    CloseHandle(dupedHandle);
	    result = 1;
#ifndef HAVE_NO_SEH
	} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
	if (result == FALSE) {
	    return NULL;
	}







|







1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
	    );
	result = registration.status;
#else
#ifndef HAVE_NO_SEH
	__try {
#endif
	    CloseHandle(dupedHandle);
	    result = TRUE;
#ifndef HAVE_NO_SEH
	} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
	if (result == FALSE) {
	    return NULL;
	}
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
     */

    infoPtr->nextPtr = NULL;
    infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION);
    infoPtr->watchMask = 0;
    infoPtr->flags = appendMode;
    infoPtr->handle = handle;
    infoPtr->dirty = 0;
    TclWinGenerateChannelName(channelName, "file", infoPtr);
    infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
	    infoPtr, permissions);

    /*
     * Files have default translation of AUTO and ^Z eof char, which means
     * that a ^Z will be accepted as EOF when reading.







|







1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
     */

    infoPtr->nextPtr = NULL;
    infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE|TCL_EXCEPTION);
    infoPtr->watchMask = 0;
    infoPtr->flags = appendMode;
    infoPtr->handle = handle;
    infoPtr->dirty = false;
    TclWinGenerateChannelName(channelName, "file", infoPtr);
    infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
	    infoPtr, permissions);

    /*
     * Files have default translation of AUTO and ^Z eof char, which means
     * that a ^Z will be accepted as EOF when reading.
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
     * OS.
     */

    for (FileInfo *infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->dirty) {
	    FlushFileBuffers(infoPtr->handle);
	    infoPtr->dirty = 0;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *







|







1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
     * OS.
     */

    for (FileInfo *infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->dirty) {
	    FlushFileBuffers(infoPtr->handle);
	    infoPtr->dirty = false;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileInfo *infoPtr = (FileInfo *)instanceData;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	infoPtr->nextPtr = tsdPtr->firstFilePtr;
	tsdPtr->firstFilePtr = infoPtr;
    } else {
	int removed = 0;

	for (FileInfo **nextPtrPtr = &(tsdPtr->firstFilePtr);
		(*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == infoPtr) {
		(*nextPtrPtr) = infoPtr->nextPtr;
		removed = 1;
		break;
	    }
	}

	/*
	 * This could happen if the channel was created in one thread and then
	 * moved to another without updating the thread local data in each







|





|







1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    FileInfo *infoPtr = (FileInfo *)instanceData;

    if (action == TCL_CHANNEL_THREAD_INSERT) {
	infoPtr->nextPtr = tsdPtr->firstFilePtr;
	tsdPtr->firstFilePtr = infoPtr;
    } else {
	bool removed = false;

	for (FileInfo **nextPtrPtr = &(tsdPtr->firstFilePtr);
		(*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
	    if ((*nextPtrPtr) == infoPtr) {
		(*nextPtrPtr) = infoPtr->nextPtr;
		removed = true;
		break;
	    }
	}

	/*
	 * This could happen if the channel was created in one thread and then
	 * moved to another without updating the thread local data in each
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
1733
1734
1735
1736
1737
1738
 *	after the fact.
 *
 *	The following patterns cover common serial port names:
 *	    COM[1-9]
 *	    \\.\COM[0-9]+
 *
 * Results:
 *	1 = serial port, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static int
NativeIsComPort(
    const WCHAR *nativePath)	/* Path of file to access, native encoding. */
{
    const WCHAR *p = (const WCHAR *) nativePath;
    size_t len = wcslen(p);

    /*
     * 1. Look for com[1-9]:?
     */

    if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) {
	/*
	 * The 4th character must be a digit 1..9
	 */

	if ((p[3] < '1') || (p[3] > '9')) {
	    return 0;
	}
	return 1;
    }

    /*
     * 2. Look for \\.\com[0-9]+
     */

    if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) {
	/*
	 * Charaters 8..end must be a digits 0..9
	 */

	for (size_t i=7; i<len; i++) {
	    if ((p[i] < '0') || (p[i] > '9')) {
		return 0;
	    }
	}
	return 1;
    }
    return 0;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|




|
















|

|













|


|

|









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
1733
1734
1735
 *	after the fact.
 *
 *	The following patterns cover common serial port names:
 *	    COM[1-9]
 *	    \\.\COM[0-9]+
 *
 * Results:
 *	true = serial port, false = not.
 *
 *----------------------------------------------------------------------
 */

static bool
NativeIsComPort(
    const WCHAR *nativePath)	/* Path of file to access, native encoding. */
{
    const WCHAR *p = (const WCHAR *) nativePath;
    size_t len = wcslen(p);

    /*
     * 1. Look for com[1-9]:?
     */

    if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) {
	/*
	 * The 4th character must be a digit 1..9
	 */

	if ((p[3] < '1') || (p[3] > '9')) {
	    return false;
	}
	return true;
    }

    /*
     * 2. Look for \\.\com[0-9]+
     */

    if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) {
	/*
	 * Charaters 8..end must be a digits 0..9
	 */

	for (size_t i=7; i<len; i++) {
	    if ((p[i] < '0') || (p[i] > '9')) {
		return false;
	    }
	}
	return true;
    }
    return false;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to win/tclWinConsole.c.
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 * For output, we do not restrict all output to the console writer threads.
 * See ConsoleOutputProc for the conditions.
 *
 * Locks are never held when calling the ReadConsole/WriteConsole API's
 * since they may block.
 */

static int gInitialized = 0;

/*
 * INPUT_BUFFER_SIZE is size of buffer passed to ReadConsole in bytes.
 * Note that ReadConsole will only allow reading of line lengths up to the
 * max of 256 and buffer size passed to it. So dropping this below 512
 * means user can type at most 256 chars.
 */







|







63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
 * For output, we do not restrict all output to the console writer threads.
 * See ConsoleOutputProc for the conditions.
 *
 * Locks are never held when calling the ReadConsole/WriteConsole API's
 * since they may block.
 */

static bool gInitialized = false;

/*
 * INPUT_BUFFER_SIZE is size of buffer passed to ReadConsole in bytes.
 * Note that ReadConsole will only allow reading of line lengths up to the
 * max of 256 and buffer size passed to it. So dropping this below 512
 * means user can type at most 256 chars.
 */
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!gInitialized) {
	AcquireSRWLockExclusive(&gConsoleLock);
	if (!gInitialized) {
	    gInitialized = 1;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	ReleaseSRWLockExclusive(&gConsoleLock);
    }

    if (TclThreadDataKeyGet(&dataKey) == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);







|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!gInitialized) {
	AcquireSRWLockExclusive(&gConsoleLock);
	if (!gInitialized) {
	    gInitialized = true;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	ReleaseSRWLockExclusive(&gConsoleLock);
    }

    if (TclThreadDataKeyGet(&dataKey) == NULL) {
	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
 */

static void
ProcExitHandler(
    TCL_UNUSED(void *))
{
    AcquireSRWLockExclusive(&gConsoleLock);
    gInitialized = 0;
    ReleaseSRWLockExclusive(&gConsoleLock);
}

/*
 *------------------------------------------------------------------------
 *
 * NudgeWatchers --







|







704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
 */

static void
ProcExitHandler(
    TCL_UNUSED(void *))
{
    AcquireSRWLockExclusive(&gConsoleLock);
    gInitialized = false;
    ReleaseSRWLockExclusive(&gConsoleLock);
}

/*
 *------------------------------------------------------------------------
 *
 * NudgeWatchers --
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
 */

void
ConsoleSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    int block = 1;

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Walk the list of channels. See general comments for struct
     * ConsoleChannelInfo with regard to locking and field access.
     */
    AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
    for (ConsoleChannelInfo *chanInfoPtr = gWatchingChannelList; block && chanInfoPtr;
	    chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
	ConsoleHandleInfo *handleInfoPtr = FindConsoleInfo(chanInfoPtr);
	if (handleInfoPtr != NULL) {
	    AcquireSRWLockShared(&handleInfoPtr->lock);
	    /* Remember at most one of READABLE, WRITABLE set */
	    if (chanInfoPtr->watchMask & TCL_READABLE) {
		if (RingBufferLength(&handleInfoPtr->buffer) > 0
			|| handleInfoPtr->lastError != ERROR_SUCCESS) {
		    block = 0; /* Input data available */
		}
	    } else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
		if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
		    /* TCL_WRITABLE */
		    block = 0; /* Output space available */
		}
	    }
	    ReleaseSRWLockShared(&handleInfoPtr->lock);
	}
    }
    ReleaseSRWLockShared(&gConsoleLock);








|



















|




|







770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
 */

void
ConsoleSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    bool block = true;

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Walk the list of channels. See general comments for struct
     * ConsoleChannelInfo with regard to locking and field access.
     */
    AcquireSRWLockShared(&gConsoleLock); /* READ lock - no data modification */
    for (ConsoleChannelInfo *chanInfoPtr = gWatchingChannelList; block && chanInfoPtr;
	    chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) {
	ConsoleHandleInfo *handleInfoPtr = FindConsoleInfo(chanInfoPtr);
	if (handleInfoPtr != NULL) {
	    AcquireSRWLockShared(&handleInfoPtr->lock);
	    /* Remember at most one of READABLE, WRITABLE set */
	    if (chanInfoPtr->watchMask & TCL_READABLE) {
		if (RingBufferLength(&handleInfoPtr->buffer) > 0
			|| handleInfoPtr->lastError != ERROR_SUCCESS) {
		    block = false; /* Input data available */
		}
	    } else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
		if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
		    /* TCL_WRITABLE */
		    block = false; /* Output space available */
		}
	    }
	    ReleaseSRWLockShared(&handleInfoPtr->lock);
	}
    }
    ReleaseSRWLockShared(&gConsoleLock);

868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
	/* Pointer is safe to access as we are holding gConsoleLock */

	if (handleInfoPtr == NULL) {
	    /* Stale event */
	    continue;
	}

	int needEvent = 0;
	AcquireSRWLockShared(&handleInfoPtr->lock);
	/* Rememeber channel is read or write, never both */
	if (chanInfoPtr->watchMask & TCL_READABLE) {
	    if (RingBufferLength(&handleInfoPtr->buffer) > 0
		    || handleInfoPtr->lastError != ERROR_SUCCESS) {
		needEvent = 1; /* Input data available or error/EOF */
	    }
	    /*
	     * TCL_READABLE watch means someone is looking out for data being
	     * available, let reader thread know. Note channel need not be
	     * ASYNC! (Bug [baa51423c2])
	     */
	    handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
	    WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
	} else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
	    if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
		needEvent = 1; /* Output space available */
	    }
	}
	ReleaseSRWLockShared(&handleInfoPtr->lock);

	if (needEvent) {
	    ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent));








|





|










|







868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
	/* Pointer is safe to access as we are holding gConsoleLock */

	if (handleInfoPtr == NULL) {
	    /* Stale event */
	    continue;
	}

	bool needEvent = false;
	AcquireSRWLockShared(&handleInfoPtr->lock);
	/* Rememeber channel is read or write, never both */
	if (chanInfoPtr->watchMask & TCL_READABLE) {
	    if (RingBufferLength(&handleInfoPtr->buffer) > 0
		    || handleInfoPtr->lastError != ERROR_SUCCESS) {
		needEvent = true; /* Input data available or error/EOF */
	    }
	    /*
	     * TCL_READABLE watch means someone is looking out for data being
	     * available, let reader thread know. Note channel need not be
	     * ASYNC! (Bug [baa51423c2])
	     */
	    handleInfoPtr->flags |= CONSOLE_DATA_AWAITED;
	    WakeConditionVariable(&handleInfoPtr->consoleThreadCV);
	} else if (chanInfoPtr->watchMask & TCL_WRITABLE) {
	    if (RingBufferHasFreeSpace(&handleInfoPtr->buffer)) {
		needEvent = true; /* Output space available */
	    }
	}
	ReleaseSRWLockShared(&handleInfoPtr->lock);

	if (needEvent) {
	    ConsoleEvent *evPtr = (ConsoleEvent *)Tcl_Alloc(sizeof(ConsoleEvent));

970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
ConsoleCloseProc(
    void *instanceData,		/* Pointer to ConsoleChannelInfo structure. */
    TCL_UNUSED(Tcl_Interp *),
    int flags)
{
    ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
    int errorCode = 0;
    int closeHandle;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
	return EINVAL;
    }
    /*
     * Don't close the Win32 handle if the handle is a standard channel
     * during the thread exit process. Otherwise, one thread may kill the
     * stdio of another while exiting. Note an explicit close in script will
     * still close the handle. That's historical behavior on all platforms.
     */
    if (!TclInThreadExit()
	    || (   (GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle)
		&& (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle)
		&& (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) {
	closeHandle = 1;
    } else {
	closeHandle = 0;
    }

    AcquireSRWLockExclusive(&gConsoleLock);

    /* Remove channel from watchers' list */
    for (ConsoleChannelInfo **nextPtrPtr = &gWatchingChannelList; *nextPtrPtr;
	    nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) {







|














|

|







970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
ConsoleCloseProc(
    void *instanceData,		/* Pointer to ConsoleChannelInfo structure. */
    TCL_UNUSED(Tcl_Interp *),
    int flags)
{
    ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
    int errorCode = 0;
    bool closeHandle;

    if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
	return EINVAL;
    }
    /*
     * Don't close the Win32 handle if the handle is a standard channel
     * during the thread exit process. Otherwise, one thread may kill the
     * stdio of another while exiting. Note an explicit close in script will
     * still close the handle. That's historical behavior on all platforms.
     */
    if (!TclInThreadExit()
	    || (   (GetStdHandle(STD_INPUT_HANDLE) != chanInfoPtr->handle)
		&& (GetStdHandle(STD_OUTPUT_HANDLE) != chanInfoPtr->handle)
		&& (GetStdHandle(STD_ERROR_HANDLE) != chanInfoPtr->handle))) {
	closeHandle = true;
    } else {
	closeHandle = false;
    }

    AcquireSRWLockExclusive(&gConsoleLock);

    /* Remove channel from watchers' list */
    for (ConsoleChannelInfo **nextPtrPtr = &gWatchingChannelList; *nextPtrPtr;
	    nextPtrPtr = &(*nextPtrPtr)->nextWatchingChannelPtr) {
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
    int mask = 0;

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    ConsoleChannelInfo *chanInfoPtr = consoleEvPtr->chanInfoPtr;
    /*
     * We know chanInfoPtr is valid because its reference count would have
     * been incremented when the event was queued. The corresponding release
     * happens in this function.







|







1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
    int mask = 0;

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    ConsoleChannelInfo *chanInfoPtr = consoleEvPtr->chanInfoPtr;
    /*
     * We know chanInfoPtr is valid because its reference count would have
     * been incremented when the event was queued. The corresponding release
     * happens in this function.
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
	Tcl_NotifyChannel(chanInfoPtr->channel, mask);
	/* Note: chanInfoPtr ref count may have changed */
    }

    /* No need to lock - see comments earlier */

    /* Remove the reference to the channel from event record */
    int freeChannel;
    if (chanInfoPtr->numRefs > 1) {
	chanInfoPtr->numRefs -= 1;
	freeChannel = 0;
    } else {
	assert(chanInfoPtr->channel == NULL);
	freeChannel = 1;
    }

    if (freeChannel) {
	Tcl_Free(chanInfoPtr);
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWatchProc --
 *







|


|


|






|







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
	Tcl_NotifyChannel(chanInfoPtr->channel, mask);
	/* Note: chanInfoPtr ref count may have changed */
    }

    /* No need to lock - see comments earlier */

    /* Remove the reference to the channel from event record */
    bool freeChannel;
    if (chanInfoPtr->numRefs > 1) {
	chanInfoPtr->numRefs -= 1;
	freeChannel = false;
    } else {
	assert(chanInfoPtr->channel == NULL);
	freeChannel = true;
    }

    if (freeChannel) {
	Tcl_Free(chanInfoPtr);
    }

    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWatchProc --
 *
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
ConsoleGetOptionProc(
    void *instanceData,		/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
    int valid = 0;		/* Flag if valid option parsed. */
    size_t len;
    char buf[TCL_INTEGER_SPACE];

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);







|







2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
ConsoleGetOptionProc(
    void *instanceData,		/* File state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
    bool valid = false;		/* Flag if valid option parsed. */
    size_t len;
    char buf[TCL_INTEGER_SPACE];

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
    if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-inputmode");
	}
	if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
	    DWORD mode;

	    valid = 1;
	    if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
		Tcl_WinConvertError(GetLastError());
		if (interp != NULL) {
		    TclPrintfResult(interp, "couldn't read console mode: %s",
			    Tcl_PosixError(interp));
		}
		return TCL_ERROR;







|







2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
    if (chanInfoPtr->flags & CONSOLE_READ_OPS) {
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-inputmode");
	}
	if (len==0 || (len>1 && strncmp(optionName, "-inputmode", len)==0)) {
	    DWORD mode;

	    valid = true;
	    if (GetConsoleMode(chanInfoPtr->handle, &mode) == 0) {
		Tcl_WinConvertError(GetLastError());
		if (interp != NULL) {
		    TclPrintfResult(interp, "couldn't read console mode: %s",
			    Tcl_PosixError(interp));
		}
		return TCL_ERROR;
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-winsize");
	}

	if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
	    CONSOLE_SCREEN_BUFFER_INFO consoleInfo;

	    valid = 1;
	    if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
		    &consoleInfo)) {
		Tcl_WinConvertError(GetLastError());
		if (interp != NULL) {
		    TclPrintfResult(interp, "couldn't read console size: %s",
			    Tcl_PosixError(interp));
		}







|







2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-winsize");
	}

	if (len == 0 || (len > 1 && strncmp(optionName, "-winsize", len) == 0)) {
	    CONSOLE_SCREEN_BUFFER_INFO consoleInfo;

	    valid = true;
	    if (!GetConsoleScreenBufferInfo(chanInfoPtr->handle,
		    &consoleInfo)) {
		Tcl_WinConvertError(GetLastError());
		if (interp != NULL) {
		    TclPrintfResult(interp, "couldn't read console size: %s",
			    Tcl_PosixError(interp));
		}
Changes to win/tclWinDde.c.
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 * The following variables cannot be placed in thread-local storage. The Mutex
 * ddeMutex guards access to the ddeInstance.
 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;	/* The application instance handle given to us
				 * by DdeInitialize. */
static int ddeIsServer = 0;

#define TCL_DDE_VERSION		"1.5a0"
#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	L"TclEval"
#define TCL_DDE_EXECUTE_RESULT	L"$TCLEVAL$EXECUTE$RESULT"

enum TclDdeFlags {







|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 * The following variables cannot be placed in thread-local storage. The Mutex
 * ddeMutex guards access to the ddeInstance.
 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;	/* The application instance handle given to us
				 * by DdeInitialize. */
static bool ddeIsServer = false;

#define TCL_DDE_VERSION		"1.5a0"
#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	L"TclEval"
#define TCL_DDE_EXECUTE_RESULT	L"$TCLEVAL$EXECUTE$RESULT"

enum TclDdeFlags {
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 *
 *----------------------------------------------------------------------
 */

static void
Initialize(void)
{
    int nameFound = 0;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    if (tsdPtr->interpListPtr != NULL) {
	nameFound = 1;
    }

    /*
     * Make sure that the DDE server is there. This is done only once, add an
     * exit handler tear it down.
     */

    if (ddeInstance == 0) {
	Tcl_MutexLock(&ddeMutex);
	if (ddeInstance == 0) {
	    if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
		    CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
		    | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
		ddeInstance = 0;
	    }
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
    if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
	Tcl_MutexLock(&ddeMutex);
	if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
	    ddeIsServer = 1;
	    Tcl_CreateExitHandler(DdeExitProc, NULL);
	    ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
		    TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
	    DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
	} else {
	    ddeIsServer = 0;
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
}

/*
 *----------------------------------------------------------------------







|









|


















|

|
|





|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
 *
 *----------------------------------------------------------------------
 */

static void
Initialize(void)
{
    bool nameFound = false;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    if (tsdPtr->interpListPtr != NULL) {
	nameFound = true;
    }

    /*
     * Make sure that the DDE server is there. This is done only once, add an
     * exit handler tear it down.
     */

    if (ddeInstance == 0) {
	Tcl_MutexLock(&ddeMutex);
	if (ddeInstance == 0) {
	    if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
		    CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
		    | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
		ddeInstance = 0;
	    }
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
    if ((ddeServiceGlobal == 0) && nameFound) {
	Tcl_MutexLock(&ddeMutex);
	if ((ddeServiceGlobal == 0) && nameFound) {
	    ddeIsServer = true;
	    Tcl_CreateExitHandler(DdeExitProc, NULL);
	    ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
		    TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
	    DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
	} else {
	    ddeIsServer = false;
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
}

/*
 *----------------------------------------------------------------------
Changes to win/tclWinFCmd.c.
1194
1195
1196
1197
1198
1199
1200
1201

1202
1203
1204
1205
1206
1207
1208
				 * may be NULL. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD sourceAttr;
    WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
    int result, found;

    Tcl_Size sourceLen, oldSourceLen, oldTargetLen, targetLen = 0;
    HANDLE handle;
    WIN32_FIND_DATAW data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;







|
>







1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
				 * may be NULL. */
    Tcl_DString *errorPtr)	/* If non-NULL, uninitialized or free DString
				 * filled with UTF-8 name of file causing
				 * error. */
{
    DWORD sourceAttr;
    WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
    int result;
    BOOL found;
    Tcl_Size sourceLen, oldSourceLen, oldTargetLen, targetLen = 0;
    HANDLE handle;
    WIN32_FIND_DATAW data;

    nativeErrfile = NULL;
    result = TCL_OK;
    oldTargetLen = 0;
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281

	targetLen = oldTargetLen;
	targetLen += sizeof(WCHAR);
	Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(targetPtr, targetLen);
    }

    found = 1;
    for (; found; found = FindNextFileW(handle, &data)) {
	WCHAR *nativeName;
	size_t len;

	WCHAR *wp = data.cFileName;
	if (*wp == '.') {
	    wp++;







|







1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282

	targetLen = oldTargetLen;
	targetLen += sizeof(WCHAR);
	Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
	Tcl_DStringSetLength(targetPtr, targetLen);
    }

    found = TRUE;
    for (; found; found = FindNextFileW(handle, &data)) {
	WCHAR *nativeName;
	size_t len;

	WCHAR *wp = data.cFileName;
	if (*wp == '.') {
	    wp++;
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    const WCHAR *nativeName;
    int attr;

    nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
    result = GetFileAttributesW(nativeName);

    if (result == 0xFFFFFFFF) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    attr = (int)(result & attributeArray[objIndex]);
    if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
	/*
	 * It is hidden. However there is a bug on some Windows OSes in which
	 * root volumes (drives) formatted as NTFS are declared hidden when
	 * they are not (and cannot be).
	 *
	 * We test for, and fix that case, here.







<









|







1521
1522
1523
1524
1525
1526
1527

1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
    Tcl_Interp *interp,		/* The interp we are using for errors. */
    int objIndex,		/* The index of the attribute. */
    Tcl_Obj *fileName,		/* The name of the file. */
    Tcl_Obj **attributePtrPtr)	/* A pointer to return the object with. */
{
    DWORD result;
    const WCHAR *nativeName;


    nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
    result = GetFileAttributesW(nativeName);

    if (result == 0xFFFFFFFF) {
	StatError(interp, fileName);
	return TCL_ERROR;
    }

    int attr = (int)(result & attributeArray[objIndex]);
    if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
	/*
	 * It is hidden. However there is a bug on some Windows OSes in which
	 * root volumes (drives) formatted as NTFS are declared hidden when
	 * they are not (and cannot be).
	 *
	 * We test for, and fix that case, here.
Changes to win/tclWinFile.c.
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
/*
 * Declarations for local functions defined in this file:
 */

static int		NativeAccess(const WCHAR *path, int mode);
static int		NativeDev(const WCHAR *path);
static int		NativeStat(const WCHAR *path, Tcl_StatBuf *statPtr,
			    int checkLinks);
static unsigned short	NativeStatMode(DWORD attr, int checkLinks,
			    int isExec);
static int		NativeIsExec(const WCHAR *path);
static int		NativeReadReparse(const WCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess);
static int		NativeWriteReparse(const WCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER *buffer);
static int		NativeMatchType(int isDrive, DWORD attr,
			    const WCHAR *nativeName, Tcl_GlobTypeData *types);
static int		WinIsDrive(const char *name, size_t nameLen);
static size_t		WinIsReserved(const char *path);
static Tcl_Obj *	WinReadLink(const WCHAR *LinkSource);
static Tcl_Obj *	WinReadLinkDirectory(const WCHAR *LinkDirectory);
static int		WinLink(const WCHAR *LinkSource,
			    const WCHAR *LinkTarget, int linkAction);
static int		WinSymLinkDirectory(const WCHAR *LinkDirectory,
			    const WCHAR *LinkTarget);







|
|
|
|




|

|







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
/*
 * Declarations for local functions defined in this file:
 */

static int		NativeAccess(const WCHAR *path, int mode);
static int		NativeDev(const WCHAR *path);
static int		NativeStat(const WCHAR *path, Tcl_StatBuf *statPtr,
			    bool checkLinks);
static unsigned short	NativeStatMode(DWORD attr, bool checkLinks,
			    bool isExec);
static bool		NativeIsExec(const WCHAR *path);
static int		NativeReadReparse(const WCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess);
static int		NativeWriteReparse(const WCHAR *LinkDirectory,
			    REPARSE_DATA_BUFFER *buffer);
static bool		NativeMatchType(bool isDrive, DWORD attr,
			    const WCHAR *nativeName, Tcl_GlobTypeData *types);
static bool		WinIsDrive(const char *name, size_t nameLen);
static size_t		WinIsReserved(const char *path);
static Tcl_Obj *	WinReadLink(const WCHAR *LinkSource);
static Tcl_Obj *	WinReadLinkDirectory(const WCHAR *LinkDirectory);
static int		WinLink(const WCHAR *LinkSource,
			    const WCHAR *LinkTarget, int linkAction);
static int		WinSymLinkDirectory(const WCHAR *LinkDirectory,
			    const WCHAR *LinkTarget);
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
    } else {
	DWORD attr;
	HANDLE handle;
	WIN32_FIND_DATAW data;
	const char *dirName;	/* UTF-8 dir name, later with pattern
				 * appended. */
	Tcl_Size dirLength;
	int matchSpecialDots;
	Tcl_DString ds;		/* Native encoding of dir, also used
				 * temporarily for other things. */
	Tcl_DString dsOrig;	/* UTF-8 encoding of dir. */
	Tcl_Obj *fileNamePtr;
	char lastChar;

	/*







|







942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
    } else {
	DWORD attr;
	HANDLE handle;
	WIN32_FIND_DATAW data;
	const char *dirName;	/* UTF-8 dir name, later with pattern
				 * appended. */
	Tcl_Size dirLength;
	bool matchSpecialDots;
	Tcl_DString ds;		/* Native encoding of dir, also used
				 * temporarily for other things. */
	Tcl_DString dsOrig;	/* UTF-8 encoding of dir. */
	Tcl_Obj *fileNamePtr;
	char lastChar;

	/*
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
	 * with a dot are not considered hidden on Windows, and so otherwise a
	 * relative glob like 'glob -join * *' will actually return
	 * './. ../..' etc.
	 */

	if ((pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'))) {
	    matchSpecialDots = 1;
	} else {
	    matchSpecialDots = 0;
	}

	/*
	 * Now iterate over all of the files in the directory, starting with
	 * the first one we found.
	 */

	do {
	    const char *utfname;
	    int checkDrive = 0, isDrive;

	    native = data.cFileName;
	    attr = data.dwFileAttributes;
	    Tcl_DStringInit(&ds);
	    utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds);

	    if (!matchSpecialDots) {







|

|









|







1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
	 * with a dot are not considered hidden on Windows, and so otherwise a
	 * relative glob like 'glob -join * *' will actually return
	 * './. ../..' etc.
	 */

	if ((pattern[0] == '.')
		|| ((pattern[0] == '\\') && (pattern[1] == '.'))) {
	    matchSpecialDots = true;
	} else {
	    matchSpecialDots = false;
	}

	/*
	 * Now iterate over all of the files in the directory, starting with
	 * the first one we found.
	 */

	do {
	    const char *utfname;
	    bool checkDrive = false;

	    native = data.cFileName;
	    attr = data.dwFileAttributes;
	    Tcl_DStringInit(&ds);
	    utfname = Tcl_WCharToUtfDString(native, TCL_INDEX_NONE, &ds);

	    if (!matchSpecialDots) {
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
1139
1140
1141
1142
1143
1144
1145
1146
	    } else if (utfname[0] == '.' && utfname[1] == '.'
		    && utfname[2] == '\0') {
		/*
		 * Have to check if this is a drive below, so we can correctly
		 * match 'hidden' and not hidden files.
		 */

		checkDrive = 1;
	    }

	    /*
	     * Check to see if the file matches the pattern. Note that we are
	     * ignoring the case sensitivity flag because Windows doesn't
	     * honor case even if the volume is case sensitive. If the volume
	     * also doesn't preserve case, then we previously returned the
	     * lower case form of the name. This didn't seem quite right since
	     * there are non-case-preserving volumes that actually return
	     * mixed case. So now we are returning exactly what we get from
	     * the system.
	     */

	    if (Tcl_StringCaseMatch(utfname, pattern, 1)) {
		/*
		 * If the file matches, then we need to process the remainder
		 * of the path.
		 */


		if (checkDrive) {
		    const char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
			    Tcl_DStringLength(&ds));

		    isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
		    Tcl_DStringSetLength(&dsOrig, dirLength);
		} else {
		    isDrive = 0;
		}
		if (NativeMatchType(isDrive, attr, native, types)) {
		    Tcl_ListObjAppendElement(interp, resultPtr,
			    TclNewFSPathObj(pathPtr, utfname,
				    Tcl_DStringLength(&ds)));
		}
	    }







|



















>







|







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
1139
1140
1141
1142
1143
1144
1145
1146
1147
	    } else if (utfname[0] == '.' && utfname[1] == '.'
		    && utfname[2] == '\0') {
		/*
		 * Have to check if this is a drive below, so we can correctly
		 * match 'hidden' and not hidden files.
		 */

		checkDrive = true;
	    }

	    /*
	     * Check to see if the file matches the pattern. Note that we are
	     * ignoring the case sensitivity flag because Windows doesn't
	     * honor case even if the volume is case sensitive. If the volume
	     * also doesn't preserve case, then we previously returned the
	     * lower case form of the name. This didn't seem quite right since
	     * there are non-case-preserving volumes that actually return
	     * mixed case. So now we are returning exactly what we get from
	     * the system.
	     */

	    if (Tcl_StringCaseMatch(utfname, pattern, 1)) {
		/*
		 * If the file matches, then we need to process the remainder
		 * of the path.
		 */

		bool isDrive;
		if (checkDrive) {
		    const char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
			    Tcl_DStringLength(&ds));

		    isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
		    Tcl_DStringSetLength(&dsOrig, dirLength);
		} else {
		    isDrive = false;
		}
		if (NativeMatchType(isDrive, attr, native, types)) {
		    Tcl_ListObjAppendElement(interp, resultPtr,
			    TclNewFSPathObj(pathPtr, utfname,
				    Tcl_DStringLength(&ds)));
		}
	    }
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174

/*
 * Does the given path represent a root volume? We need this special case
 * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden'
 * attribute when it should not.
 */

static int
WinIsDrive(
    const char *name,		/* Name (UTF-8) */
    size_t len)			/* Length of name */
{
    int remove = 0;

    while (len > 4) {







|







1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175

/*
 * Does the given path represent a root volume? We need this special case
 * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden'
 * attribute when it should not.
 */

static bool
WinIsDrive(
    const char *name,		/* Name (UTF-8) */
    size_t len)			/* Length of name */
{
    int remove = 0;

    while (len > 4) {
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
	     * Not sure if this is possible, but we pass it on anyway.
	     */
	} else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
	    /*
	     * Path is pointing to the root volume.
	     */

	    return 1;
	} else if ((name[1] == ':')
		   && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
	    /*
	     * Path is of the form 'x:' or 'x:/' or 'x:\'
	     */

	    return 1;
	}
    }

    return 0;
}

/*
 * Does the given path represent a reserved window path name? If not return 0,
 * if true, return the number of characters of the path that we actually want
 * (not any trailing :).
 */







|






|



|







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
	     * Not sure if this is possible, but we pass it on anyway.
	     */
	} else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
	    /*
	     * Path is pointing to the root volume.
	     */

	    return true;
	} else if ((name[1] == ':')
		   && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
	    /*
	     * Path is of the form 'x:' or 'x:/' or 'x:\'
	     */

	    return true;
	}
    }

    return false;
}

/*
 * Does the given path represent a reserved window path name? If not return 0,
 * if true, return the number of characters of the path that we actually want
 * (not any trailing :).
 */
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
 *	'hidden' attribute when it should not.
 *
 *	We never make any calls to a 'get attributes' routine here, since we
 *	have arranged things so that our caller already knows such
 *	information.
 *
 * Results:
 *	0 = file doesn't match
 *	1 = file matches
 *
 *----------------------------------------------------------------------
 */

static int
NativeMatchType(
    int isDrive,		/* Is this a drive. */
    DWORD attr,			/* We already know the attributes for the
				 * file. */
    const WCHAR *nativeName,	/* Native path to check. */
    Tcl_GlobTypeData *types)	/* Type description to match against. */
{
    /*
     * 'attr' represents the attributes of the file, but we only want to







|
|




|

|







1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
 *	'hidden' attribute when it should not.
 *
 *	We never make any calls to a 'get attributes' routine here, since we
 *	have arranged things so that our caller already knows such
 *	information.
 *
 * Results:
 *	false = file doesn't match
 *	true = file matches
 *
 *----------------------------------------------------------------------
 */

static bool
NativeMatchType(
    bool isDrive,		/* Is this a drive. */
    DWORD attr,			/* We already know the attributes for the
				 * file. */
    const WCHAR *nativeName,	/* Native path to check. */
    Tcl_GlobTypeData *types)	/* Type description to match against. */
{
    /*
     * 'attr' represents the attributes of the file, but we only want to
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409

    if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
	/*
	 * If invisible.
	 */

	if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
	    return 0;
	}
    } else {
	/*
	 * Visible.
	 */

	if (types->perm & TCL_GLOB_PERM_HIDDEN) {
	    return 0;
	}
    }

    if (types->perm != 0) {
	if (((types->perm & TCL_GLOB_PERM_RONLY) &&
		    !(attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_R) &&
		    (0 /* File exists => R_OK on Windows */)) ||
		((types->perm & TCL_GLOB_PERM_W) &&
		    (attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_X) &&
		    (!(attr & FILE_ATTRIBUTE_DIRECTORY)
		    && !NativeIsExec(nativeName)))) {
	    return 0;
	}
    }

    if ((types->type & TCL_GLOB_TYPE_DIR)
	    && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * Quicker test for directory, which is a common case.
	 */

	return 1;

    } else if (types->type != 0) {
	unsigned short st_mode;
	int isExec = NativeIsExec(nativeName);

	st_mode = NativeStatMode(attr, 0, isExec);

	/*
	 * In order bcdpfls as in 'find -t'
	 */

	if (((types->type&TCL_GLOB_TYPE_BLOCK)    && S_ISBLK(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_DIR)  && S_ISDIR(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
#ifdef S_ISSOCK
		((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
#endif
		((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
	    /*
	     * Do nothing - this file is ok.
	     */
	} else {
#ifdef S_ISLNK
	    if (types->type & TCL_GLOB_TYPE_LINK) {
		st_mode = NativeStatMode(attr, 1, isExec);
		if (S_ISLNK(st_mode)) {
		    return 1;
		}
	    }
#endif /* S_ISLNK */
	    return 0;
	}
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *







|







|













|









|


<
|
<
|



















|

|



|


|







1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370

1371

1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408

    if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
	/*
	 * If invisible.
	 */

	if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
	    return false;
	}
    } else {
	/*
	 * Visible.
	 */

	if (types->perm & TCL_GLOB_PERM_HIDDEN) {
	    return false;
	}
    }

    if (types->perm != 0) {
	if (((types->perm & TCL_GLOB_PERM_RONLY) &&
		    !(attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_R) &&
		    (0 /* File exists => R_OK on Windows */)) ||
		((types->perm & TCL_GLOB_PERM_W) &&
		    (attr & FILE_ATTRIBUTE_READONLY)) ||
		((types->perm & TCL_GLOB_PERM_X) &&
		    (!(attr & FILE_ATTRIBUTE_DIRECTORY)
		    && !NativeIsExec(nativeName)))) {
	    return false;
	}
    }

    if ((types->type & TCL_GLOB_TYPE_DIR)
	    && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * Quicker test for directory, which is a common case.
	 */

	return true;

    } else if (types->type != 0) {

	bool isExec = NativeIsExec(nativeName);

	unsigned short st_mode = NativeStatMode(attr, false, isExec);

	/*
	 * In order bcdpfls as in 'find -t'
	 */

	if (((types->type&TCL_GLOB_TYPE_BLOCK)    && S_ISBLK(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_DIR)  && S_ISDIR(st_mode)) ||
		((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
#ifdef S_ISSOCK
		((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
#endif
		((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
	    /*
	     * Do nothing - this file is ok.
	     */
	} else {
#ifdef S_ISLNK
	    if (types->type & TCL_GLOB_TYPE_LINK) {
		st_mode = NativeStatMode(attr, true, isExec);
		if (S_ISLNK(st_mode)) {
		    return true;
		}
	    }
#endif /* S_ISLNK */
	    return false;
	}
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpGetUserHome --
 *
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
 *
 * Results:
 *	1 = executable, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static int
NativeIsExec(
    const WCHAR *path)
{
    size_t len = wcslen(path);

    if (len < 5) {
	return 0;
    }

    if (path[len-4] != '.') {
	return 0;
    }

    path += len-3;
    if ((_wcsicmp(path, L"exe") == 0)
	    || (_wcsicmp(path, L"com") == 0)
	    || (_wcsicmp(path, L"cmd") == 0)
	    || (_wcsicmp(path, L"bat") == 0)) {
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjChdir --
 *







|






|



|







|

|







1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
 *
 * Results:
 *	1 = executable, 0 = not.
 *
 *----------------------------------------------------------------------
 */

static bool
NativeIsExec(
    const WCHAR *path)
{
    size_t len = wcslen(path);

    if (len < 5) {
	return false;
    }

    if (path[len-4] != '.') {
	return false;
    }

    path += len-3;
    if ((_wcsicmp(path, L"exe") == 0)
	    || (_wcsicmp(path, L"com") == 0)
	    || (_wcsicmp(path, L"cmd") == 0)
	    || (_wcsicmp(path, L"bat") == 0)) {
	return true;
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjChdir --
 *
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels();

    return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *







|







1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels();

    return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, false);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
 *----------------------------------------------------------------------
 */

static int
NativeStat(
    const WCHAR *nativePath,	/* Path of file to stat */
    Tcl_StatBuf *statPtr,	/* Filled with results of stat call. */
    int checkLinks)		/* If non-zero, behave like 'lstat' */
{
    DWORD attr;
    int dev, nlink = 1;
    unsigned short mode;
    unsigned int inode = 0;
    HANDLE fileHandle;
    DWORD fileType = FILE_TYPE_UNKNOWN;







|







1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
 *----------------------------------------------------------------------
 */

static int
NativeStat(
    const WCHAR *nativePath,	/* Path of file to stat */
    Tcl_StatBuf *statPtr,	/* Filled with results of stat call. */
    bool checkLinks)		/* If true, behave like 'lstat' */
{
    DWORD attr;
    int dev, nlink = 1;
    unsigned short mode;
    unsigned int inode = 0;
    HANDLE fileHandle;
    DWORD fileType = FILE_TYPE_UNKNOWN;
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
 *
 *----------------------------------------------------------------------
 */

static unsigned short
NativeStatMode(
    DWORD attr,
    int checkLinks,
    int isExec)
{
    int mode;

    if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	/*
	 * It is a link.
	 */







|
|







2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
 *
 *----------------------------------------------------------------------
 */

static unsigned short
NativeStatMode(
    DWORD attr,
    bool checkLinks,
    bool isExec)
{
    int mode;

    if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	/*
	 * It is a link.
	 */
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381

2382

2383
2384
2385
2386


2387
2388
2389
2390
2391
2392
2393
2394
2395

2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels();

    return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}

#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
    Tcl_Obj *pathPtr,
    Tcl_Obj *toPtr,
    int linkAction)
{
    if (toPtr != NULL) {
	int res;
	const WCHAR *LinkTarget;
	const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
	Tcl_Obj *normToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);

	if (normToPtr == NULL) {
	    return NULL;
	}
	if (normToPtr != toPtr) { Tcl_IncrRefCount(normToPtr); }



	LinkTarget = (const WCHAR *)Tcl_FSGetNativePath(normToPtr);

	if (LinkSource == NULL || LinkTarget == NULL) {
	    if (normToPtr != toPtr) { Tcl_DecrRefCount(normToPtr); }


	    return NULL;
	}
	res = WinLink(LinkSource, LinkTarget, linkAction);
	if (normToPtr != toPtr) { Tcl_DecrRefCount(normToPtr); }
	if (res == 0) {
	    return toPtr;
	} else {
	    return NULL;
	}

    } else {
	const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

	if (LinkSource == NULL) {
	    return NULL;
	}
	return WinReadLink(LinkSource);
    }
}
#endif /* S_IFLNK */

/*
 *---------------------------------------------------------------------------
 *







|










<
<
|





|
>
|
>
|

|
|
>
>


|
|
<
|
<
<

>

|

|


|







2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371


2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391

2392


2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
     * Ensure correct file sizes by forcing the OS to write any pending data
     * to disk. This is done only for channels which are dirty, i.e. have been
     * written to since the last flush here.
     */

    TclWinFlushDirtyChannels();

    return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, true);
}

#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
    Tcl_Obj *pathPtr,
    Tcl_Obj *toPtr,
    int linkAction)
{
    if (toPtr != NULL) {


	const WCHAR *linkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
	Tcl_Obj *normToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);

	if (normToPtr == NULL) {
	    return NULL;
	}
	if (normToPtr != toPtr) {
	    Tcl_IncrRefCount(normToPtr);
	}

	const WCHAR *linkTarget = (const WCHAR *)Tcl_FSGetNativePath(normToPtr);

	if (linkSource == NULL || linkTarget == NULL) {
	    if (normToPtr != toPtr) {
		Tcl_DecrRefCount(normToPtr);
	    }
	    return NULL;
	}
	int res = WinLink(linkSource, linkTarget, linkAction);
	if (normToPtr != toPtr) {

	    Tcl_DecrRefCount(normToPtr);


	}
	return (res == 0) ? toPtr : NULL;
    } else {
	const WCHAR *linkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

	if (linkSource == NULL) {
	    return NULL;
	}
	return WinReadLink(linkSource);
    }
}
#endif /* S_IFLNK */

/*
 *---------------------------------------------------------------------------
 *
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458

2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
 */

Tcl_Obj *
TclpFilesystemPathType(
    Tcl_Obj *pathPtr)
{
#define VOL_BUF_SIZE 32
    int found;
    WCHAR volType[VOL_BUF_SIZE];
    char *firstSeparator;
    const char *path;
    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

    if (normPath == NULL) {
	return NULL;
    }
    path = TclGetString(normPath);
    if (path == NULL) {
	return NULL;
    }

    firstSeparator = strchr((char *)path, '/');
    if (firstSeparator == NULL) {
	found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr),
		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
    } else {
	Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);

	Tcl_IncrRefCount(driveName);
	found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(driveName),
		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
	Tcl_DecrRefCount(driveName);
    }

    if (found == 0) {
	return NULL;

    } else {
	Tcl_DString ds;

	Tcl_DStringInit(&ds);
	Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds);
	return Tcl_DStringToObj(&ds);
    }
#undef VOL_BUF_SIZE
}

/*
 * This define can be turned on to experiment with a different way of
 * normalizing paths (using a different Windows API). Unfortunately the new
 * path seems to take almost exactly the same amount of time as the old path!







|

|
<

<



|




|












|

>
|
|
<
|
|
|
<







2422
2423
2424
2425
2426
2427
2428
2429
2430
2431

2432

2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458

2459
2460
2461

2462
2463
2464
2465
2466
2467
2468
 */

Tcl_Obj *
TclpFilesystemPathType(
    Tcl_Obj *pathPtr)
{
#define VOL_BUF_SIZE 32
    BOOL found;
    WCHAR volType[VOL_BUF_SIZE];


    Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);

    if (normPath == NULL) {
	return NULL;
    }
    const char *path = TclGetString(normPath);
    if (path == NULL) {
	return NULL;
    }

    char *firstSeparator = strchr((char *)path, '/');
    if (firstSeparator == NULL) {
	found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr),
		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
    } else {
	Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);

	Tcl_IncrRefCount(driveName);
	found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(driveName),
		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
	Tcl_DecrRefCount(driveName);
    }

    if (!found) {
	return NULL;
    }

    Tcl_DString ds;

    Tcl_DStringInit(&ds);
    Tcl_WCharToUtfDString(volType, TCL_INDEX_NONE, &ds);
    return Tcl_DStringToObj(&ds);

#undef VOL_BUF_SIZE
}

/*
 * This define can be turned on to experiment with a different way of
 * normalizing paths (using a different Windows API). Unfortunately the new
 * path seems to take almost exactly the same amount of time as the old path!
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
				 * normalize */
    int nextCheckpoint1)		/* offset to start at in pathPtr */
{
    char *lastValidPathEnd = NULL;
    Tcl_DString dsNorm;		/* This will hold the normalized string. */
    char *path, *currentPathEndPosition;
    Tcl_Obj *temp = NULL;
    int isDrive = 1;
    Tcl_DString ds;		/* Some workspace. */
    Tcl_Size nextCheckpoint = nextCheckpoint1;

    Tcl_DStringInit(&dsNorm);
    path = TclGetString(pathPtr);

    currentPathEndPosition = path + nextCheckpoint;







|







2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
				 * normalize */
    int nextCheckpoint1)		/* offset to start at in pathPtr */
{
    char *lastValidPathEnd = NULL;
    Tcl_DString dsNorm;		/* This will hold the normalized string. */
    char *path, *currentPathEndPosition;
    Tcl_Obj *temp = NULL;
    bool isDrive = true;
    Tcl_DString ds;		/* Some workspace. */
    Tcl_Size nextCheckpoint = nextCheckpoint1;

    Tcl_DStringInit(&dsNorm);
    path = TclGetString(pathPtr);

    currentPathEndPosition = path + nextCheckpoint;
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
		    }
		    temp = to;

		    /*
		     * Reset variables so we can restart normalization.
		     */

		    isDrive = 1;
		    Tcl_DStringFree(&dsNorm);
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH







|







2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
		    }
		    temp = to;

		    /*
		     * Reset variables so we can restart normalization.
		     */

		    isDrive = true;
		    Tcl_DStringFree(&dsNorm);
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
	    }

	    /*
	     * 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
	/*
	 * Convert the entire known path to long form.
	 */







|







2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
	    }

	    /*
	     * If we get here, we've got past one directory delimiter, so we
	     * know it is no longer a drive.
	     */

	    isDrive = false;
	}
	currentPathEndPosition++;

#ifdef TclNORM_LONG_PATH
	/*
	 * Convert the entire known path to long form.
	 */
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
    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 = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR));
    if (nativePathPtr==0) {
	goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
	    (DWORD)len + 2);
    nativePathPtr[len] = 0;

    /*







|









|







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
    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 = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR));
    if (nativePathPtr == 0) {
	goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
	    (DWORD)len + 2);
    nativePathPtr[len] = 0;

    /*
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
{
    const WCHAR *native;
    PSID ownerSid = NULL;
    PSECURITY_DESCRIPTOR secd = NULL;
    HANDLE token;
    LPBYTE buf = NULL;
    DWORD bufsz;
    int owned = 0;

    native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfoW((LPWSTR) 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.







|











|







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
{
    const WCHAR *native;
    PSID ownerSid = NULL;
    PSECURITY_DESCRIPTOR secd = NULL;
    HANDLE token;
    LPBYTE buf = NULL;
    DWORD bufsz;
    BOOL owned = FALSE;

    native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfoW((LPWSTR) 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 false;
    }

    /*
     * 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.
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
    if (secd) {
	LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
	Tcl_Free(buf);
    }

    return (owned != 0);        /* Convert non-0 to 1 */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */







|









3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
    if (secd) {
	LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
	Tcl_Free(buf);
    }

    return (owned != FALSE);        /* Convert non-0 to 1 */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
Changes to win/tclWinInit.c.
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
 */

void
TclpSetVariables(
    Tcl_Interp *interp)		/* Interp to initialize. */
{
    typedef int(__stdcall getVersionProc)(void *);
    const char *ptr;
    char buffer[TCL_INTEGER_SPACE * 2];
    union {
	SYSTEM_INFO info;
	OemId oemId;
    } sys;
    static OSVERSIONINFOW osInfo;
    static int osInfoInitialized = 0;
    Tcl_DString ds;

    Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
	    TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);

    if (!osInfoInitialized) {
	HMODULE handle = GetModuleHandleW(L"NTDLL");
	getVersionProc *getVersion = (getVersionProc *) (void *)
		GetProcAddress(handle, "RtlGetVersion");

	osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
	if (!getVersion || getVersion(&osInfo)) {
	    GetVersionExW(&osInfo);
	}
	osInfoInitialized = 1;
    }
    GetSystemInfo(&sys.info);

    /*
     * Define the tcl_platform array.
     */








<






|














|







589
590
591
592
593
594
595

596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
 */

void
TclpSetVariables(
    Tcl_Interp *interp)		/* Interp to initialize. */
{
    typedef int(__stdcall getVersionProc)(void *);

    char buffer[TCL_INTEGER_SPACE * 2];
    union {
	SYSTEM_INFO info;
	OemId oemId;
    } sys;
    static OSVERSIONINFOW osInfo;
    static bool osInfoInitialized = false;
    Tcl_DString ds;

    Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
	    TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);

    if (!osInfoInitialized) {
	HMODULE handle = GetModuleHandleW(L"NTDLL");
	getVersionProc *getVersion = (getVersionProc *) (void *)
		GetProcAddress(handle, "RtlGetVersion");

	osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
	if (!getVersion || getVersion(&osInfo)) {
	    GetVersionExW(&osInfo);
	}
	osInfoInitialized = true;
    }
    GetSystemInfo(&sys.info);

    /*
     * Define the tcl_platform array.
     */

640
641
642
643
644
645
646
647
648
649
650
651
652
653
654

    /*
     * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
     * environment variables, if necessary.
     */

    Tcl_DStringInit(&ds);
    ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
    if (ptr == NULL) {
	ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
	if (ptr != NULL) {
	    Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
	}
	ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
	if (ptr != NULL) {







|







639
640
641
642
643
644
645
646
647
648
649
650
651
652
653

    /*
     * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
     * environment variables, if necessary.
     */

    Tcl_DStringInit(&ds);
    const char *ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
    if (ptr == NULL) {
	ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
	if (ptr != NULL) {
	    Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
	}
	ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
	if (ptr != NULL) {
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
    Tcl_Size *lengthPtr)	/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    Tcl_Size i, length, result = TCL_INDEX_NONE;
    const WCHAR *env;
    const char *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.
     */

    length = strlen(name);
    nameUpper = (char *)Tcl_Alloc(length + 1);
    memcpy(nameUpper, name, length+1);
    Tcl_UtfToUpper(nameUpper);

    Tcl_DStringInit(&envString);
    for (i = 0, env = _wenviron[i]; env != NULL; i++, env = _wenviron[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	Tcl_DStringInit(&envString);
	envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

	p1 = envUpper;
	p2 = nameUpper;
	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = length;
	    result = i;
	    goto done;







<
<







|












|
|








|







714
715
716
717
718
719
720


721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
    Tcl_Size *lengthPtr)	/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    Tcl_Size i, length, result = TCL_INDEX_NONE;
    const WCHAR *env;


    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive comparison.
     */

    length = strlen(name);
    char *nameUpper = (char *)Tcl_Alloc(length + 1);
    memcpy(nameUpper, name, length+1);
    Tcl_UtfToUpper(nameUpper);

    Tcl_DStringInit(&envString);
    for (i = 0, env = _wenviron[i]; env != NULL; i++, env = _wenviron[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert the name
	 * to all upper case, so we do not have to convert all the characters
	 * after the equal sign.
	 */

	Tcl_DStringInit(&envString);
	char *envUpper = Tcl_WCharToUtfDString(env, TCL_INDEX_NONE, &envString);
	const char *p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

	p1 = envUpper;
	const char *p2 = nameUpper;
	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = length;
	    result = i;
	    goto done;
Changes to win/tclWinInt.h.
97
98
99
100
101
102
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
    PTI_STATE_END = 4,		/* thread should stop work (worker is busy) */
    PTI_STATE_DOWN = 8		/* worker is down */
};

MODULE_SCOPE
TclPipeThreadInfo *	TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
			    void *clientData);
MODULE_SCOPE int	TclPipeThreadWaitForSignal(
			    TclPipeThreadInfo **pipeTIPtr);

static inline void
TclPipeThreadSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    if (pipeTI) {
	SetEvent(pipeTI->evControl);
    }
};

static inline int
TclPipeThreadIsAlive(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    return (pipeTI && pipeTI->state != PTI_STATE_DOWN);
};

MODULE_SCOPE int	TclPipeThreadStopSignal(TclPipeThreadInfo **pipeTIPtr);
MODULE_SCOPE void	TclPipeThreadStop(TclPipeThreadInfo **pipeTIPtr,
			    HANDLE hThread);
MODULE_SCOPE void	TclPipeThreadExit(TclPipeThreadInfo **pipeTIPtr);

#endif	/* _TCLWININT */







|




















|





97
98
99
100
101
102
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
    PTI_STATE_END = 4,		/* thread should stop work (worker is busy) */
    PTI_STATE_DOWN = 8		/* worker is down */
};

MODULE_SCOPE
TclPipeThreadInfo *	TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
			    void *clientData);
MODULE_SCOPE bool	TclPipeThreadWaitForSignal(
			    TclPipeThreadInfo **pipeTIPtr);

static inline void
TclPipeThreadSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    if (pipeTI) {
	SetEvent(pipeTI->evControl);
    }
};

static inline int
TclPipeThreadIsAlive(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    return (pipeTI && pipeTI->state != PTI_STATE_DOWN);
};

MODULE_SCOPE bool	TclPipeThreadStopSignal(TclPipeThreadInfo **pipeTIPtr);
MODULE_SCOPE void	TclPipeThreadStop(TclPipeThreadInfo **pipeTIPtr,
			    HANDLE hThread);
MODULE_SCOPE void	TclPipeThreadExit(TclPipeThreadInfo **pipeTIPtr);

#endif	/* _TCLWININT */
Changes to win/tclWinNotify.c.
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

typedef struct ThreadSpecificData_Notifier_Windows {
    CRITICAL_SECTION crit;	/* Monitor for this notifier. */
    DWORD thread;		/* Identifier for thread associated with this
				 * notifier. */
    HANDLE event;		/* Event object used to wake up the notifier
				 * thread. */
    int pending;		/* Alert message pending, this field is locked
				 * by the notifierMutex. */
    HWND hwnd;			/* Messaging window. */
    int timerActive;		/* 1 if interval timer is running. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following static indicates the number of threads that have initialized
 * notifiers. It controls the lifetime of the TclNotifier window class.
 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;
static const WCHAR className[] = L"TclNotifier";
static int initialized = 0;
static CRITICAL_SECTION notifierMutex;

/*
 * Static routines defined in this file.
 */

static LRESULT CALLBACK	NotifierProc(HWND hwnd, UINT message,







|


|













|







32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63

typedef struct ThreadSpecificData_Notifier_Windows {
    CRITICAL_SECTION crit;	/* Monitor for this notifier. */
    DWORD thread;		/* Identifier for thread associated with this
				 * notifier. */
    HANDLE event;		/* Event object used to wake up the notifier
				 * thread. */
    bool pending;		/* Alert message pending, this field is locked
				 * by the notifierMutex. */
    HWND hwnd;			/* Messaging window. */
    bool timerActive;		/* true if interval timer is running. */
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * The following static indicates the number of threads that have initialized
 * notifiers. It controls the lifetime of the TclNotifier window class.
 *
 * You must hold the notifierMutex lock before accessing this variable.
 */

static int notifierCount = 0;
static const WCHAR className[] = L"TclNotifier";
static bool initialized = false;
static CRITICAL_SECTION notifierMutex;

/*
 * Static routines defined in this file.
 */

static LRESULT CALLBACK	NotifierProc(HWND hwnd, UINT message,
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
void *
TclpInitNotifier(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TclpGlobalLock();
    if (!initialized) {
	initialized = 1;
	InitializeCriticalSection(&notifierMutex);
    }
    TclpGlobalUnlock();

    /*
     * Register Notifier window class if this is the first thread to use this
     * module.







|







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
void *
TclpInitNotifier(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TclpGlobalLock();
    if (!initialized) {
	initialized = true;
	InitializeCriticalSection(&notifierMutex);
    }
    TclpGlobalUnlock();

    /*
     * Register Notifier window class if this is the first thread to use this
     * module.
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
	    Tcl_Panic("Tcl_InitNotifier: %s",
		    "unable to register TclNotifier window class");
	}
    }
    notifierCount++;
    LeaveCriticalSection(&notifierMutex);

    tsdPtr->pending = 0;
    tsdPtr->timerActive = 0;

    InitializeCriticalSection(&tsdPtr->crit);

    tsdPtr->hwnd = NULL;
    tsdPtr->thread = GetCurrentThreadId();
    tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
	    FALSE /* !signaled */, NULL);







|
|







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
	    Tcl_Panic("Tcl_InitNotifier: %s",
		    "unable to register TclNotifier window class");
	}
    }
    notifierCount++;
    LeaveCriticalSection(&notifierMutex);

    tsdPtr->pending = false;
    tsdPtr->timerActive = false;

    InitializeCriticalSection(&tsdPtr->crit);

    tsdPtr->hwnd = NULL;
    tsdPtr->thread = GetCurrentThreadId();
    tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
	    FALSE /* !signaled */, NULL);
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
	 * We do need to lock around access to the pending flag.
	 */

	EnterCriticalSection(&tsdPtr->crit);
	if (!tsdPtr->pending) {
	    PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
	}
	tsdPtr->pending = 1;
	LeaveCriticalSection(&tsdPtr->crit);
    } else {
	SetEvent(tsdPtr->event);
    }
}

/*







|







236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
	 * We do need to lock around access to the pending flag.
	 */

	EnterCriticalSection(&tsdPtr->crit);
	if (!tsdPtr->pending) {
	    PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
	}
	tsdPtr->pending = true;
	LeaveCriticalSection(&tsdPtr->crit);
    } else {
	SetEvent(tsdPtr->event);
    }
}

/*
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
	timeout = (UINT)timePtr->sec * 1000 + (unsigned long)timePtr->usec / 1000;
	if (timeout == 0) {
	    timeout = 1;
	}
    }

    if (timeout != 0) {
	tsdPtr->timerActive = 1;
	SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, timeout, NULL);
    } else {
	tsdPtr->timerActive = 0;
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
    }
}

/*
 *----------------------------------------------------------------------
 *







|


|







293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
	timeout = (UINT)timePtr->sec * 1000 + (unsigned long)timePtr->usec / 1000;
	if (timeout == 0) {
	    timeout = 1;
	}
    }

    if (timeout != 0) {
	tsdPtr->timerActive = true;
	SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, timeout, NULL);
    } else {
	tsdPtr->timerActive = false;
	KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
    }
}

/*
 *----------------------------------------------------------------------
 *
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
 *----------------------------------------------------------------------
 *
 * TclAsyncNotifier --
 *
 *	This procedure is a no-op on Windows.
 *
 * Result:
 *	Always true.
 *
 * Side effetcs:
 *	None.
 *----------------------------------------------------------------------
 */

int

TclAsyncNotifier(
    TCL_UNUSED(int),		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),	/* Notifier data. */
    TCL_UNUSED(int *),		/* Flag to mark. */
    TCL_UNUSED(int))			/* Value of mark. */
{
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierProc --
 *







|






<
>



|

|

|







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
 *----------------------------------------------------------------------
 *
 * TclAsyncNotifier --
 *
 *	This procedure is a no-op on Windows.
 *
 * Result:
 *	Always false.
 *
 * Side effetcs:
 *	None.
 *----------------------------------------------------------------------
 */


bool
TclAsyncNotifier(
    TCL_UNUSED(int),		/* Signal number. */
    TCL_UNUSED(Tcl_ThreadId),	/* Target thread. */
    TCL_UNUSED(void *),		/* Notifier data. */
    TCL_UNUSED(int *),		/* Flag to mark. */
    TCL_UNUSED(int))		/* Value of mark. */
{
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * NotifierProc --
 *
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
    WPARAM wParam,		/* Passed on... */
    LPARAM lParam)		/* Passed on... */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (message == WM_WAKEUP) {
	EnterCriticalSection(&tsdPtr->crit);
	tsdPtr->pending = 0;
	LeaveCriticalSection(&tsdPtr->crit);
    } else if (message != WM_TIMER) {
	return DefWindowProcW(hwnd, message, wParam, lParam);
    }

    /*
     * Process all of the runnable events.







|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
    WPARAM wParam,		/* Passed on... */
    LPARAM lParam)		/* Passed on... */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (message == WM_WAKEUP) {
	EnterCriticalSection(&tsdPtr->crit);
	tsdPtr->pending = false;
	LeaveCriticalSection(&tsdPtr->crit);
    } else if (message != WM_TIMER) {
	return DefWindowProcW(hwnd, message, wParam, lParam);
    }

    /*
     * Process all of the runnable events.
Changes to win/tclWinPipe.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#include "tclWinInt.h"

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;

/*
 * The pipeMutex locks around access to the initialized and procList
 * variables, and it is used to protect background threads from being
 * terminated while they are using APIs that hold locks.
 */








|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
#include "tclWinInt.h"

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static bool initialized = false;

/*
 * The pipeMutex locks around access to the initialized and procList
 * variables, and it is used to protect background threads from being
 * terminated while they are using APIs that hold locks.
 */

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&pipeMutex);
	if (!initialized) {
	    initialized = 1;
	    procList = NULL;
	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {







|







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
     * Check the initialized flag first, then check again in the mutex. This
     * is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&pipeMutex);
	if (!initialized) {
	    initialized = true;
	    procList = NULL;
	}
	Tcl_MutexUnlock(&pipeMutex);
    }

    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
 */

void
PipeSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    int block = 1;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events are already pending.  If they are, poll.
     */

    for (PipeInfo *infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = 0;
	    }
	}
	if (infoPtr->watchMask & TCL_READABLE) {
	    if (WaitForRead(infoPtr, 0) >= 0) {
		block = 0;
	    }
	}
    }
    if (!block) {
	Tcl_Time blockTime = { 0, 0 };
	Tcl_SetMaxBlockTime(&blockTime);
    }







|














|




|







307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
 */

void
PipeSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    bool block = true;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events are already pending.  If they are, poll.
     */

    for (PipeInfo *infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
	    infoPtr = infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
		block = false;
	    }
	}
	if (infoPtr->watchMask & TCL_READABLE) {
	    if (WaitForRead(infoPtr, 0) >= 0) {
		block = false;
	    }
	}
    }
    if (!block) {
	Tcl_Time blockTime = { 0, 0 };
	Tcl_SetMaxBlockTime(&blockTime);
    }
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
	    continue;
	}

	/*
	 * Queue an event if the pipe is signaled for reading or writing.
	 */

	int needEvent = 0;
	if ((infoPtr->watchMask & TCL_WRITABLE) &&
		(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	    needEvent = 1;
	}

	if ((infoPtr->watchMask & TCL_READABLE) &&
		(WaitForRead(infoPtr, 0) >= 0)) {
	    needEvent = 1;
	}

	if (needEvent) {
	    infoPtr->flags |= PIPE_PENDING;
	    PipeEvent *evPtr = (PipeEvent *)Tcl_Alloc(sizeof(PipeEvent));
	    evPtr->header.proc = PipeEventProc;
	    evPtr->infoPtr = infoPtr;







|


|




|







379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
	    continue;
	}

	/*
	 * Queue an event if the pipe is signaled for reading or writing.
	 */

	bool needEvent = false;
	if ((infoPtr->watchMask & TCL_WRITABLE) &&
		(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
	    needEvent = true;
	}

	if ((infoPtr->watchMask & TCL_READABLE) &&
		(WaitForRead(infoPtr, 0) >= 0)) {
	    needEvent = true;
	}

	if (needEvent) {
	    infoPtr->flags |= PIPE_PENDING;
	    PipeEvent *evPtr = (PipeEvent *)Tcl_Alloc(sizeof(PipeEvent));
	    evPtr->header.proc = PipeEventProc;
	    evPtr->infoPtr = infoPtr;
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
    int flags)			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    PipeEvent *pipeEvPtr = (PipeEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched pipes for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that pipes can be deleted while the event is in
     * the queue.







|







2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
    int flags)			/* Flags that indicate what events to
				 * handle, such as TCL_FILE_EVENTS. */
{
    PipeEvent *pipeEvPtr = (PipeEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the list of watched pipes for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that pipes can be deleted while the event is in
     * the queue.
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the pipe is readable. Note that we can't tell if a pipe
     * is writable, so we always report it as being writable unless we have
     * detected EOF.
     */







|







2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return true;
    }

    /*
     * Check to see if the pipe is readable. Note that we can't tell if a pipe
     * is writable, so we always report it as being writable unless we have
     * detected EOF.
     */
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
    }

    /*
     * Inform the channel of the events.
     */

    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWatchProc --
 *







|







2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
    }

    /*
     * Inform the channel of the events.
     */

    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * PipeWatchProc --
 *
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
    PipeInfo *infoPtr = NULL;	/* access info only after success init/wait */
    HANDLE handle = NULL;

    for (int done=0; !done; ) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */







|







2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
    PipeInfo *infoPtr = NULL;	/* access info only after success init/wait */
    HANDLE handle = NULL;

    for (bool done=false; !done; ) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
	     * The error is a result of an EOF condition, so set the EOF bit
	     * before signalling the main thread.
	     */

	    DWORD err = GetLastError();
	    if (err == ERROR_BROKEN_PIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		done = 1;
	    } else if (err == ERROR_INVALID_HANDLE) {
		done = 1;
	    }
	} else if (count == 0) {
	    if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
		    != FALSE) {
		/*
		 * One byte was consumed as a side effect of waiting for the
		 * pipe to become readable.
		 */

		infoPtr->readFlags |= PIPE_EXTRABYTE;
	    } else {
		DWORD err = GetLastError();
		if (err == ERROR_BROKEN_PIPE) {
		    /*
		     * The error is a result of an EOF condition, so set the
		     * EOF bit before signalling the main thread.
		     */

		    infoPtr->readFlags |= PIPE_EOF;
		    done = 1;
		} else if (err == ERROR_INVALID_HANDLE) {
		    done = 1;
		}
	    }
	}

	/*
	 * Signal the main thread by signalling the readable event and then
	 * waking up the notifier thread.







|

|



















|

|







2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
	     * The error is a result of an EOF condition, so set the EOF bit
	     * before signalling the main thread.
	     */

	    DWORD err = GetLastError();
	    if (err == ERROR_BROKEN_PIPE) {
		infoPtr->readFlags |= PIPE_EOF;
		done = true;
	    } else if (err == ERROR_INVALID_HANDLE) {
		done = true;
	    }
	} else if (count == 0) {
	    if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
		    != FALSE) {
		/*
		 * One byte was consumed as a side effect of waiting for the
		 * pipe to become readable.
		 */

		infoPtr->readFlags |= PIPE_EXTRABYTE;
	    } else {
		DWORD err = GetLastError();
		if (err == ERROR_BROKEN_PIPE) {
		    /*
		     * The error is a result of an EOF condition, so set the
		     * EOF bit before signalling the main thread.
		     */

		    infoPtr->readFlags |= PIPE_EOF;
		    done = true;
		} else if (err == ERROR_INVALID_HANDLE) {
		    done = true;
		}
	    }
	}

	/*
	 * Signal the main thread by signalling the readable event and then
	 * waking up the notifier thread.
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
PipeWriterThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
    PipeInfo *infoPtr = NULL;	/* access info only after success init/wait */
    HANDLE handle = NULL;

    for (int done=0; !done; ) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */
	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}







|







3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
PipeWriterThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
    PipeInfo *infoPtr = NULL;	/* access info only after success init/wait */
    HANDLE handle = NULL;

    for (bool done=false; !done; ) {
	/*
	 * Wait for the main thread to signal before attempting to write.
	 */
	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    DWORD count;
	    if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
		infoPtr->writeError = GetLastError();
		done = 1;
		break;
	    } else {
		toWrite -= count;
		buf += count;
	    }
	}








|







3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
	 * Loop until all of the bytes are written or an error occurs.
	 */

	while (toWrite > 0) {
	    DWORD count;
	    if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
		infoPtr->writeError = GetLastError();
		done = true;
		break;
	    } else {
		toWrite -= count;
		buf += count;
	    }
	}

3278
3279
3280
3281
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
 *----------------------------------------------------------------------
 *
 * TclPipeThreadWaitForSignal --
 *
 *	Wait for work/stop signals inside pipe worker.
 *
 * Results:
 *	1 if signaled to work, 0 if signaled to stop.
 *
 * Side effects:
 *	If this function returns 0, TI-structure pointer given via pipeTIPtr
 *	may be NULL, so not accessible (can be owned by main thread).
 *
 *----------------------------------------------------------------------
 */

int

TclPipeThreadWaitForSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    if (!pipeTI) {
	return 0;
    }

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */

    /*







|


|
|




<
>






|







3278
3279
3280
3281
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
 *----------------------------------------------------------------------
 *
 * TclPipeThreadWaitForSignal --
 *
 *	Wait for work/stop signals inside pipe worker.
 *
 * Results:
 *	true if signaled to work, false if signaled to stop.
 *
 * Side effects:
 *	If this function returns false, TI-structure pointer given via
 *	pipeTIPtr may be NULL, so not accessible (can be owned by main thread).
 *
 *----------------------------------------------------------------------
 */


bool
TclPipeThreadWaitForSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    if (!pipeTI) {
	return false;
    }

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */

    /*
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
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
	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;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadStopSignal --
 *
 *	Send stop signal to the pipe worker (without waiting).
 *
 *	After calling of this function, TI-structure pointer given via pipeTIPtr
 *	may be NULL.
 *
 * Results:
 *	1 if signaled (or pipe-thread is down), 0 if pipe thread still working.

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

int

TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    if (!pipeTI) {
	return 1;
    }
    HANDLE evControl = pipeTI->evControl;
    int 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;
	TCL_FALLTHROUGH();
    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;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadStop --
 *







|









|













|
>




<
>






|














|












|







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
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
	goto end;
    }

    /*
     * Signaled to work.
     */

    return true;

  end:
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadStopSignal --
 *
 *	Send stop signal to the pipe worker (without waiting).
 *
 *	After calling of this function, TI-structure pointer given via pipeTIPtr
 *	may be NULL.
 *
 * Results:
 *	true if signaled (or pipe-thread is down), false if pipe thread still
 *	working.
 *
 *----------------------------------------------------------------------
 */


bool
TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    if (!pipeTI) {
	return true;
    }
    HANDLE evControl = pipeTI->evControl;
    int 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;
	TCL_FALLTHROUGH();
    case PTI_STATE_DOWN:
	return true;

    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 false;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadStop --
 *
Changes to win/tclWinSerial.c.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
#include "tclWinInt.h"

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static int initialized = 0;

/*
 * The serialMutex locks around access to the initialized variable, and it is
 * used to protect background threads from being terminated while they are
 * using APIs that hold locks.
 */








|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
#include "tclWinInt.h"

/*
 * The following variable is used to tell whether this module has been
 * initialized.
 */

static bool initialized = false;

/*
 * The serialMutex locks around access to the initialized variable, and it is
 * used to protect background threads from being terminated while they are
 * using APIs that hold locks.
 */

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
    int validMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    int readable;		/* Flag that the channel is readable. */
    int writable;		/* Flag that the channel is writable. */
    int blockTime;		/* Maximum blocktime in msec. */
    unsigned long long lastEventTime;
				/* Time in milliseconds since last readable
				 * event. */
				/* Next readable event only after blockTime */
    DWORD error;		/* pending error code returned by
				 * ClearCommError() */







|
|







81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
    int validMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which operations are valid on the file. */
    int watchMask;		/* OR'ed combination of TCL_READABLE,
				 * TCL_WRITABLE, or TCL_EXCEPTION: indicates
				 * which events should be reported. */
    int flags;			/* State flags, see above for a list. */
    bool readable;		/* Flag that the channel is readable. */
    bool writable;		/* Flag that the channel is writable. */
    int blockTime;		/* Maximum blocktime in msec. */
    unsigned long long lastEventTime;
				/* Time in milliseconds since last readable
				 * event. */
				/* Next readable event only after blockTime */
    DWORD error;		/* pending error code returned by
				 * ClearCommError() */
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
     * Check the initialized flag first, then check it again in the mutex.
     * This is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&serialMutex);
	if (!initialized) {
	    initialized = 1;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&serialMutex);
    }

    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);







|







248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
     * Check the initialized flag first, then check it again in the mutex.
     * This is a speed enhancement.
     */

    if (!initialized) {
	Tcl_MutexLock(&serialMutex);
	if (!initialized) {
	    initialized = true;
	    Tcl_CreateExitHandler(ProcExitHandler, NULL);
	}
	Tcl_MutexUnlock(&serialMutex);
    }

    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
 */

static void
ProcExitHandler(
    TCL_UNUSED(void *))
{
    Tcl_MutexLock(&serialMutex);
    initialized = 0;
    Tcl_MutexUnlock(&serialMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --







|







324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
 */

static void
ProcExitHandler(
    TCL_UNUSED(void *))
{
    Tcl_MutexLock(&serialMutex);
    initialized = false;
    Tcl_MutexUnlock(&serialMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SerialBlockTime --
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
#endif

void
SerialSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    int block = 1;
    int msec = INT_MAX;		/* min. found block time */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events handlers installed. If they are, do not
     * block.
     */

    for (SerialInfo *infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
		block = 0;
		msec = min(msec, infoPtr->blockTime);
	    }
	}
	if (infoPtr->watchMask & TCL_READABLE) {
	    block = 0;
	    msec = min(msec, infoPtr->blockTime);
	}
    }

    if (!block) {
	SerialBlockTime(msec);
    }







|
















|




|







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
#endif

void
SerialSetupProc(
    TCL_UNUSED(void *),
    int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
{
    bool block = true;
    int msec = INT_MAX;		/* min. found block time */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return;
    }

    /*
     * Look to see if any events handlers installed. If they are, do not
     * block.
     */

    for (SerialInfo *infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->watchMask & TCL_WRITABLE) {
	    if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
		block = false;
		msec = min(msec, infoPtr->blockTime);
	    }
	}
	if (infoPtr->watchMask & TCL_READABLE) {
	    block = false;
	    msec = min(msec, infoPtr->blockTime);
	}
    }

    if (!block) {
	SerialBlockTime(msec);
    }
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

    for (SerialInfo *infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->flags & SERIAL_PENDING) {
	    continue;
	}

	int needEvent = 0;

	/*
	 * If WRITABLE watch mask is set look for infoPtr->evWritable object.
	 */

	if (infoPtr->watchMask & TCL_WRITABLE &&
		WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
	    infoPtr->writable = 1;
	    needEvent = 1;
	}

	/*
	 * If READABLE watch mask is set call ClearCommError to poll cbInQue.
	 * Window errors are ignored here.
	 */








|







|
|







479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

    for (SerialInfo *infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ;
	    infoPtr=infoPtr->nextPtr) {
	if (infoPtr->flags & SERIAL_PENDING) {
	    continue;
	}

	bool needEvent = false;

	/*
	 * If WRITABLE watch mask is set look for infoPtr->evWritable object.
	 */

	if (infoPtr->watchMask & TCL_WRITABLE &&
		WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
	    infoPtr->writable = true;
	    needEvent = true;
	}

	/*
	 * If READABLE watch mask is set call ClearCommError to poll cbInQue.
	 * Window errors are ignored here.
	 */

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
		if (infoPtr->watchMask & TCL_READABLE) {
		    /*
		     * Force fileevent after serial read error.
		     */

		    if ((cStat.cbInQue > 0) ||
			    (infoPtr->error & SERIAL_READ_ERRORS)) {
			infoPtr->readable = 1;
			unsigned long long time = SerialGetMilliseconds();
			if ((time - infoPtr->lastEventTime)
				>= (unsigned long long) infoPtr->blockTime) {
			    needEvent = 1;
			    infoPtr->lastEventTime = time;
			}
		    }
		}
	    }
	}








|



|







511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
		if (infoPtr->watchMask & TCL_READABLE) {
		    /*
		     * Force fileevent after serial read error.
		     */

		    if ((cStat.cbInQue > 0) ||
			    (infoPtr->error & SERIAL_READ_ERRORS)) {
			infoPtr->readable = true;
			unsigned long long time = SerialGetMilliseconds();
			if ((time - infoPtr->lastEventTime)
				>= (unsigned long long) infoPtr->blockTime) {
			    needEvent = true;
			    infoPtr->lastEventTime = time;
			}
		    }
		}
	    }
	}

1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Search through the list of watched serials for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that serials can be deleted while the event is
     * in the queue.







|







1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!(flags & TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Search through the list of watched serials for the one whose handle
     * matches the event. We do this rather than simply dereferencing the
     * handle in the event so that serials can be deleted while the event is
     * in the queue.
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return 1;
    }

    /*
     * Check to see if the serial is readable. Note that we can't tell if a
     * serial is writable, so we always report it as being writable unless we
     * have detected EOF.
     */

    int mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (infoPtr->writable) {
	    mask |= TCL_WRITABLE;
	    infoPtr->writable = 0;
	}
    }

    if (infoPtr->watchMask & TCL_READABLE) {
	if (infoPtr->readable) {
	    mask |= TCL_READABLE;
	    infoPtr->readable = 0;
	}
    }

    /*
     * Inform the channel of the events.
     */

    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWatchProc --
 *







|












|






|








|







1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
    }

    /*
     * Remove stale events.
     */

    if (!infoPtr) {
	return true;
    }

    /*
     * Check to see if the serial is readable. Note that we can't tell if a
     * serial is writable, so we always report it as being writable unless we
     * have detected EOF.
     */

    int mask = 0;
    if (infoPtr->watchMask & TCL_WRITABLE) {
	if (infoPtr->writable) {
	    mask |= TCL_WRITABLE;
	    infoPtr->writable = false;
	}
    }

    if (infoPtr->watchMask & TCL_READABLE) {
	if (infoPtr->readable) {
	    mask |= TCL_READABLE;
	    infoPtr->readable = false;
	}
    }

    /*
     * Inform the channel of the events.
     */

    Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * SerialWatchProc --
 *
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458

    SerialInfo *infoPtr = (SerialInfo *)Tcl_Alloc(sizeof(SerialInfo));
    memset(infoPtr, 0, sizeof(SerialInfo));

    infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE);
    infoPtr->handle = handle;
    infoPtr->channel = (Tcl_Channel) NULL;
    infoPtr->readable = 0;
    infoPtr->writable = 1;
    infoPtr->toWrite = infoPtr->writeQueue = 0;
    infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
    infoPtr->lastEventTime = 0;
    infoPtr->lastError = infoPtr->error = 0;
    infoPtr->threadId = Tcl_GetCurrentThread();
    infoPtr->sysBufRead = 4096;
    infoPtr->sysBufWrite = 4096;







|
|







1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458

    SerialInfo *infoPtr = (SerialInfo *)Tcl_Alloc(sizeof(SerialInfo));
    memset(infoPtr, 0, sizeof(SerialInfo));

    infoPtr->validMask = permissions & (TCL_READABLE|TCL_WRITABLE);
    infoPtr->handle = handle;
    infoPtr->channel = (Tcl_Channel) NULL;
    infoPtr->readable = false;
    infoPtr->writable = true;
    infoPtr->toWrite = infoPtr->writeQueue = 0;
    infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
    infoPtr->lastEventTime = 0;
    infoPtr->lastError = infoPtr->error = 0;
    infoPtr->threadId = Tcl_GetCurrentThread();
    infoPtr->sysBufRead = 4096;
    infoPtr->sysBufWrite = 4096;
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
    void *instanceData,		/* Serial state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    size_t len;
    int valid = 0;		/* Flag if valid option parsed. */

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }








|







2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
    void *instanceData,		/* Serial state. */
    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
    const char *optionName,	/* Option to get. */
    Tcl_DString *dsPtr)		/* Where to store value(s). */
{
    SerialInfo *infoPtr = (SerialInfo *) instanceData;
    size_t len;
    bool valid = false;		/* Flag if valid option parsed. */

    if (optionName == NULL) {
	len = 0;
    } else {
	len = strlen(optionName);
    }

2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get comm state: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}

	valid = 1;
	parity = 'n';
	if (dcb.Parity <= 4) {
	    parity = "noems"[dcb.Parity];
	}
	stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
		(dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";








|







2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get comm state: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}

	valid = true;
	parity = 'n';
	if (dcb.Parity <= 4) {
	    parity = "noems"[dcb.Parity];
	}
	stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
		(dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";

2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-pollinterval");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) {
	char buf[TCL_INTEGER_SPACE + 1];

	valid = 1;
	snprintf(buf, sizeof(buf), "%d", infoPtr->blockTime);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -sysbuffer
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) {
	char buf[TCL_INTEGER_SPACE + 1];
	valid = 1;

	snprintf(buf, sizeof(buf), "%ld", infoPtr->sysBufRead);
	Tcl_DStringAppendElement(dsPtr, buf);
	snprintf(buf, sizeof(buf), "%ld", infoPtr->sysBufWrite);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * Get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
	char buf[4];
	valid = 1;

	DCB dcb;
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp != NULL) {
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get comm state: %s",
			Tcl_PosixError(interp));







|














|




















|







2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-pollinterval");
    }
    if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) {
	char buf[TCL_INTEGER_SPACE + 1];

	valid = true;
	snprintf(buf, sizeof(buf), "%d", infoPtr->blockTime);
	Tcl_DStringAppendElement(dsPtr, buf);
    }

    /*
     * Get option -sysbuffer
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) {
	char buf[TCL_INTEGER_SPACE + 1];
	valid = true;

	snprintf(buf, sizeof(buf), "%ld", infoPtr->sysBufRead);
	Tcl_DStringAppendElement(dsPtr, buf);
	snprintf(buf, sizeof(buf), "%ld", infoPtr->sysBufWrite);
	Tcl_DStringAppendElement(dsPtr, buf);
    }
    if (len == 0) {
	Tcl_DStringEndSublist(dsPtr);
    }

    /*
     * Get option -xchar
     */

    if (len == 0) {
	Tcl_DStringAppendElement(dsPtr, "-xchar");
	Tcl_DStringStartSublist(dsPtr);
    }
    if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
	char buf[4];
	valid = true;

	DCB dcb;
	if (!GetCommState(infoPtr->handle, &dcb)) {
	    if (interp != NULL) {
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get comm state: %s",
			Tcl_PosixError(interp));
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
     * Get option -lasterror
     *
     * Option is readonly and returned by [fconfigure chan -lasterror] but not
     * returned by unnamed [fconfigure chan].
     */

    if (len>1 && strncmp(optionName, "-lasterror", len)==0) {
	valid = 1;
	SerialErrorStr(infoPtr->lastError, dsPtr);
    }

    /*
     * get option -queue
     *
     * Option is readonly and returned by [fconfigure chan -queue].
     */

    if (len>1 && strncmp(optionName, "-queue", len)==0) {
	char buf[TCL_INTEGER_SPACE + 1];
	COMSTAT cStat;
	DWORD error;
	int inBuffered, outBuffered, count;

	valid = 1;

	/*
	 * Query the pending data in Tcl's internal queues.
	 */

	inBuffered  = Tcl_InputBuffered(infoPtr->channel);
	outBuffered = Tcl_OutputBuffered(infoPtr->channel);







|















|







2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
     * Get option -lasterror
     *
     * Option is readonly and returned by [fconfigure chan -lasterror] but not
     * returned by unnamed [fconfigure chan].
     */

    if (len>1 && strncmp(optionName, "-lasterror", len)==0) {
	valid = true;
	SerialErrorStr(infoPtr->lastError, dsPtr);
    }

    /*
     * get option -queue
     *
     * Option is readonly and returned by [fconfigure chan -queue].
     */

    if (len>1 && strncmp(optionName, "-queue", len)==0) {
	char buf[TCL_INTEGER_SPACE + 1];
	COMSTAT cStat;
	DWORD error;
	int inBuffered, outBuffered, count;

	valid = true;

	/*
	 * Query the pending data in Tcl's internal queues.
	 */

	inBuffered  = Tcl_InputBuffered(infoPtr->channel);
	outBuffered = Tcl_OutputBuffered(infoPtr->channel);
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
	    if (interp != NULL) {
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get tty status: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}
	valid = 1;
	SerialModemStatusStr(status, dsPtr);
    }

    if (valid) {
	return TCL_OK;
    }
    return Tcl_BadChannelOption(interp, optionName,







|







2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
	    if (interp != NULL) {
		Tcl_WinConvertError(GetLastError());
		TclPrintfResult(interp, "can't get tty status: %s",
			Tcl_PosixError(interp));
	    }
	    return TCL_ERROR;
	}
	valid = true;
	SerialModemStatusStr(status, dsPtr);
    }

    if (valid) {
	return TCL_OK;
    }
    return Tcl_BadChannelOption(interp, optionName,
Changes to win/tclWinSock.c.
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

/*
 * The following variable is used to tell whether this module has been
 * initialized.  If 1, initialization of sockets was successful, if -1 then
 * socket initialization failed (WSAStartup failed).
 */

static int initialized = 0;
static const WCHAR className[] = L"TclSocket";
TCL_DECLARE_MUTEX(socketMutex)

/*
 * The following defines declare the messages used on socket windows.
 */
enum TclSocketMessages {







|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

/*
 * The following variable is used to tell whether this module has been
 * initialized.  If 1, initialization of sockets was successful, if -1 then
 * socket initialization failed (WSAStartup failed).
 */

static bool initialized = false;
static const WCHAR className[] = L"TclSocket";
TCL_DECLARE_MUTEX(socketMutex)

/*
 * The following defines declare the messages used on socket windows.
 */
enum TclSocketMessages {
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
static void		InitSocketWindowClass(void);
static TcpState *	NewSocketInfo(SOCKET socket);
static void		SocketExitHandler(void *clientData);
static LRESULT CALLBACK	SocketProc(HWND hwnd, UINT message, WPARAM wParam,
			    LPARAM lParam);
static void		TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
static int		WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static int		WaitForSocketEvent(TcpState *statePtr, int events,
			    int *errorCodePtr);
static void		AddSocketInfoFd(TcpState *statePtr, SOCKET socket);
static int		FindFDInList(TcpState *statePtr, SOCKET socket);
static DWORD WINAPI	SocketThread(LPVOID arg);
static void		TcpThreadActionProc(void *instanceData,
			    int action);
static int		TcpCloseProc(void *, Tcl_Interp *);

static Tcl_EventCheckProc	SocketCheckProc;
static Tcl_EventProc		SocketEventProc;







|


|







239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
static void		InitSocketWindowClass(void);
static TcpState *	NewSocketInfo(SOCKET socket);
static void		SocketExitHandler(void *clientData);
static LRESULT CALLBACK	SocketProc(HWND hwnd, UINT message, WPARAM wParam,
			    LPARAM lParam);
static void		TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr);
static int		WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static bool		WaitForSocketEvent(TcpState *statePtr, int events,
			    int *errorCodePtr);
static void		AddSocketInfoFd(TcpState *statePtr, SOCKET socket);
static bool		FindFDInList(TcpState *statePtr, SOCKET socket);
static DWORD WINAPI	SocketThread(LPVOID arg);
static void		TcpThreadActionProc(void *instanceData,
			    int action);
static int		TcpCloseProc(void *, Tcl_Interp *);

static Tcl_EventCheckProc	SocketCheckProc;
static Tcl_EventProc		SocketEventProc;
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
		}
		return TCL_ERROR;
	    }
	}
    }

    if ((len == 0) || HAVE_OPTION("-sockname")) {
	int found = 0;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-sockname");
	    Tcl_DStringStartSublist(dsPtr);
	}
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
	    /*
	     * In async connect output an empty string
	     */

	    found = 1;
	} else {
	    for (TcpFdList *fds = statePtr->sockets; fds; fds = fds->next) {
		address sockname;
		socklen_t size = sizeof(sockname);
		sock = fds->fd;
		if (getsockname(sock, &(sockname.sa), &size) >= 0) {
		    int flags = reverseDNS;

		    found = 1;
		    getnameinfo(&sockname.sa, size, host, sizeof(host),
			    NULL, 0, NI_NUMERICHOST);
		    Tcl_DStringAppendElement(dsPtr, host);

		    /*
		     * We don't want to resolve INADDR_ANY and sin6addr_any;
		     * they can sometimes cause problems (and never have a







|










|








|







1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
		}
		return TCL_ERROR;
	    }
	}
    }

    if ((len == 0) || HAVE_OPTION("-sockname")) {
	bool found = false;

	if (len == 0) {
	    Tcl_DStringAppendElement(dsPtr, "-sockname");
	    Tcl_DStringStartSublist(dsPtr);
	}
	if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
	    /*
	     * In async connect output an empty string
	     */

	    found = true;
	} else {
	    for (TcpFdList *fds = statePtr->sockets; fds; fds = fds->next) {
		address sockname;
		socklen_t size = sizeof(sockname);
		sock = fds->fd;
		if (getsockname(sock, &(sockname.sa), &size) >= 0) {
		    int flags = reverseDNS;

		    found = true;
		    getnameinfo(&sockname.sa, size, host, sizeof(host),
			    NULL, 0, NI_NUMERICHOST);
		    Tcl_DStringAppendElement(dsPtr, host);

		    /*
		     * We don't want to resolve INADDR_ANY and sin6addr_any;
		     * they can sometimes cause problems (and never have a
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
		 * It is set after this call by TcpThreadActionProc and is set
		 * on a second round.
		 *
		 * If not, we buffer my statePtr in the tsd memory so it is
		 * not lost by the event procedure
		 */

		int in_socket_list = 0;
		for (TcpState *statePtr2 = tsdPtr->socketList; statePtr2;
			statePtr2 = statePtr2->nextPtr) {
		    if (statePtr2 == statePtr) {
			in_socket_list = 1;
			break;
		    }
		}
		if (!in_socket_list) {
		    tsdPtr->pendingTcpState = statePtr;
		}








|



|







1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
		 * It is set after this call by TcpThreadActionProc and is set
		 * on a second round.
		 *
		 * If not, we buffer my statePtr in the tsd memory so it is
		 * not lost by the event procedure
		 */

		bool in_socket_list = false;
		for (TcpState *statePtr2 = tsdPtr->socketList; statePtr2;
			statePtr2 = statePtr2->nextPtr) {
		    if (statePtr2 == statePtr) {
			in_socket_list = true;
			break;
		    }
		}
		if (!in_socket_list) {
		    tsdPtr->pendingTcpState = statePtr;
		}

2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
    SOCKET sock = INVALID_SOCKET;
    unsigned short chosenport = 0;
    struct addrinfo *addrlist = NULL;
    TcpState *statePtr = NULL;	/* The returned value. */
    char channelName[SOCK_CHAN_LENGTH];
    u_long flag = 1;		/* Indicates nonblocking mode. */
    const char *errorMsg = NULL;
    int optvalue, port;

    TclInitSockets();

    /*
     * Construct the addresses for each end of the socket.
     */








|







2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
    SOCKET sock = INVALID_SOCKET;
    unsigned short chosenport = 0;
    struct addrinfo *addrlist = NULL;
    TcpState *statePtr = NULL;	/* The returned value. */
    char channelName[SOCK_CHAN_LENGTH];
    u_long flag = 1;		/* Indicates nonblocking mode. */
    const char *errorMsg = NULL;
    int port;

    TclInitSockets();

    /*
     * Construct the addresses for each end of the socket.
     */

2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
	 *
	 * As sockaddr_in6 uses the same offset and size for the port
	 * member as sockaddr_in, we can handle both through the IPv4 API.
	 */

	if (port == 0 && chosenport != 0) {
	    ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
		htons(chosenport);
	}

	/*
	 * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on
	 * unix systems.
	 */

	if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) {
	    optvalue = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
		    (char *) &optvalue, sizeof(optvalue));
	}

	/*
	 * Bind to the specified port.
	 *







|








|







2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
	 *
	 * As sockaddr_in6 uses the same offset and size for the port
	 * member as sockaddr_in, we can handle both through the IPv4 API.
	 */

	if (port == 0 && chosenport != 0) {
	    ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
		    htons(chosenport);
	}

	/*
	 * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on
	 * unix systems.
	 */

	if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) {
	    int optvalue = 1;
	    (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
		    (char *) &optvalue, sizeof(optvalue));
	}

	/*
	 * Bind to the specified port.
	 *
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
InitSocketWindowClass(void)
{
    if (initialized) {
	return;
    }
    Tcl_MutexLock(&socketMutex);
    if (!initialized) {
	initialized = 1;
	TclCreateLateExitHandler(SocketExitHandler, NULL);

	/*
	 * Create the async notification window with a new class. We must
	 * create a new class to avoid a Windows 95 bug that causes us to get
	 * the wrong message number for socket events if the message window is
	 * a subclass of a static control.







|







2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
InitSocketWindowClass(void)
{
    if (initialized) {
	return;
    }
    Tcl_MutexLock(&socketMutex);
    if (!initialized) {
	initialized = true;
	TclCreateLateExitHandler(SocketExitHandler, NULL);

	/*
	 * Create the async notification window with a new class. We must
	 * create a new class to avoid a Windows 95 bug that causes us to get
	 * the wrong message number for socket events if the message window is
	 * a subclass of a static control.
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
    /*
     * Make sure the socket event handling window is cleaned-up for, at
     * most, this thread.
     */

    TclpFinalizeSockets();
    UnregisterClassW(className, (HINSTANCE)TclWinGetTclInstance());
    initialized = 0;
    Tcl_MutexUnlock(&socketMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --







|







2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
    /*
     * Make sure the socket event handling window is cleaned-up for, at
     * most, this thread.
     */

    TclpFinalizeSockets();
    UnregisterClassW(className, (HINSTANCE)TclWinGetTclInstance());
    initialized = false;
    Tcl_MutexUnlock(&socketMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * SocketSetupProc --
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
2586
2587
2588
2589
2590
2591
2592
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    TcpState *statePtr;
    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0, events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    SOCKET newSocket;
    address addr;
    int len;

    if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
	return 0;
    }

    /*
     * Find the specified socket on the socket list.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (statePtr = tsdPtr->socketList; statePtr != NULL;
	    statePtr = statePtr->nextPtr) {
	if (statePtr->sockets->fd == eventPtr->socket) {
	    break;
	}
    }

    /*
     * Discard events that have gone stale.
     */

    if (!statePtr) {
	SetEvent(tsdPtr->socketListLock);
	return 1;
    }

    /*
     * Clear flag that (this) event is pending
     */

    CLEAR_BITS(statePtr->flags, SOCKET_PENDING);







<
<
<


|




















|







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
2586
2587
2588
2589
    int flags)			/* Flags that indicate what events to handle,
				 * such as TCL_FILE_EVENTS. */
{
    TcpState *statePtr;
    SocketEvent *eventPtr = (SocketEvent *) evPtr;
    int mask = 0, events;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);




    if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
	return false;
    }

    /*
     * Find the specified socket on the socket list.
     */

    WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
    for (statePtr = tsdPtr->socketList; statePtr != NULL;
	    statePtr = statePtr->nextPtr) {
	if (statePtr->sockets->fd == eventPtr->socket) {
	    break;
	}
    }

    /*
     * Discard events that have gone stale.
     */

    if (!statePtr) {
	SetEvent(tsdPtr->socketListLock);
	return true;
    }

    /*
     * Clear flag that (this) event is pending
     */

    CLEAR_BITS(statePtr->flags, SOCKET_PENDING);
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
	    /*
	     * No async connect reenter pending. Just clear event.
	     */

	    CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
	    SetEvent(tsdPtr->socketListLock);
	}
	return 1;
    }

    /*
     * Handle connection requests directly.
     */

    if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) {
	for (TcpFdList *fds = statePtr->sockets; fds != NULL; fds = fds->next) {
	    /*
	     * Accept the incoming connection request.
	     */


	    len = sizeof(address);
	    newSocket = accept(fds->fd, &(addr.sa), &len);

	    /*
	     * On Tcl server sockets with multiple OS fds we loop over the fds
	     * trying an accept() on each, so we expect INVALID_SOCKET.  There
	     * are also other network stack conditions that can result in
	     * FD_ACCEPT but a subsequent failure on accept() by the time we
	     * get around to it.







|












>
|
|







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
	    /*
	     * No async connect reenter pending. Just clear event.
	     */

	    CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
	    SetEvent(tsdPtr->socketListLock);
	}
	return true;
    }

    /*
     * Handle connection requests directly.
     */

    if (GOT_BITS(statePtr->readyEvents, FD_ACCEPT)) {
	for (TcpFdList *fds = statePtr->sockets; fds != NULL; fds = fds->next) {
	    /*
	     * Accept the incoming connection request.
	     */

	    address addr;
	    socklen_t len = sizeof(addr);
	    SOCKET newSocket = accept(fds->fd, &(addr.sa), &len);

	    /*
	     * On Tcl server sockets with multiple OS fds we loop over the fds
	     * trying an accept() on each, so we expect INVALID_SOCKET.  There
	     * are also other network stack conditions that can result in
	     * FD_ACCEPT but a subsequent failure on accept() by the time we
	     * get around to it.
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
	     * server accept script (via AcceptCallbackProc() in tclIOCmd.c),
	     * which can close the server socket and invalidate statePtr and
	     * fds. If TcpAccept() accepts a socket we must return immediately
	     * and let SocketCheckProc queue additional FD_ACCEPT events.
	     */

	    TcpAccept(fds, newSocket, addr);
	    return 1;
	}

	/*
	 * Loop terminated with no sockets accepted; clear the ready mask so
	 * we can detect the next connection request. Note that connection
	 * requests are level triggered, so if there is a request already
	 * pending, a new event will be generated.
	 */

	statePtr->acceptEventCount = 0;
	CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);

	SetEvent(tsdPtr->socketListLock);
	return 1;
    }

    SetEvent(tsdPtr->socketListLock);

    /*
     * Mask off unwanted events and compute the read/write mask so we can
     * notify the channel.







|













|







2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
	     * server accept script (via AcceptCallbackProc() in tclIOCmd.c),
	     * which can close the server socket and invalidate statePtr and
	     * fds. If TcpAccept() accepts a socket we must return immediately
	     * and let SocketCheckProc queue additional FD_ACCEPT events.
	     */

	    TcpAccept(fds, newSocket, addr);
	    return true;
	}

	/*
	 * Loop terminated with no sockets accepted; clear the ready mask so
	 * we can detect the next connection request. Note that connection
	 * requests are level triggered, so if there is a request already
	 * pending, a new event will be generated.
	 */

	statePtr->acceptEventCount = 0;
	CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT);

	SetEvent(tsdPtr->socketListLock);
	return true;
    }

    SetEvent(tsdPtr->socketListLock);

    /*
     * Mask off unwanted events and compute the read/write mask so we can
     * notify the channel.
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733

2734
2735
2736
2737
2738
2739
2740
	 * Throw the readable event if an async connect failed.
	 */

	if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
	    SET_BITS(mask, TCL_READABLE);
	} else {
	    fd_set readFds;
	    struct timeval timeout;

	    /*
	     * We must check to see if data is really available, since someone
	     * could have consumed the data in the meantime. Turn off async
	     * notification so select will work correctly. If the socket is
	     * still readable, notify the channel driver, otherwise reset the
	     * async select handler and keep waiting.
	     */

	    SendSelectMessage(tsdPtr, UNSELECT, statePtr);

	    FD_ZERO(&readFds);
	    FD_SET(statePtr->sockets->fd, &readFds);

	    timeout.tv_usec = 0;
	    timeout.tv_sec = 0;

	    if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
		SET_BITS(mask, TCL_READABLE);
	    } else {
		CLEAR_BITS(statePtr->readyEvents, FD_READ);







<













>







2711
2712
2713
2714
2715
2716
2717

2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
	 * Throw the readable event if an async connect failed.
	 */

	if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) {
	    SET_BITS(mask, TCL_READABLE);
	} else {
	    fd_set readFds;


	    /*
	     * We must check to see if data is really available, since someone
	     * could have consumed the data in the meantime. Turn off async
	     * notification so select will work correctly. If the socket is
	     * still readable, notify the channel driver, otherwise reset the
	     * async select handler and keep waiting.
	     */

	    SendSelectMessage(tsdPtr, UNSELECT, statePtr);

	    FD_ZERO(&readFds);
	    FD_SET(statePtr->sockets->fd, &readFds);
	    struct timeval timeout;
	    timeout.tv_usec = 0;
	    timeout.tv_sec = 0;

	    if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
		SET_BITS(mask, TCL_READABLE);
	    } else {
		CLEAR_BITS(statePtr->readyEvents, FD_READ);
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
    /*
     * Call registered event procedures
     */

    if (mask) {
	Tcl_NotifyChannel(statePtr->channel, mask);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * AddSocketInfoFd --
 *







|







2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
    /*
     * Call registered event procedures
     */

    if (mask) {
	Tcl_NotifyChannel(statePtr->channel, mask);
    }
    return true;
}

/*
 *----------------------------------------------------------------------
 *
 * AddSocketInfoFd --
 *
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
 *
 * WaitForSocketEvent --
 *
 *	Waits until one of the specified events occurs on a socket.
 *	For event FD_CONNECT use WaitForConnect.
 *
 * Results:
 *	Returns 1 on success or 0 on failure, with an error code in
 *	errorCodePtr.
 *
 * Side effects:
 *	Processes socket events off the system queue.
 *
 *----------------------------------------------------------------------
 */

static int
WaitForSocketEvent(
    TcpState *statePtr,		/* Information about this socket. */
    int events,			/* Events to look for. May be one of
				 * FD_READ or FD_WRITE. */
    int *errorCodePtr)		/* Where to store errors? */
{
    int result = 1;
    int oldMode;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    /*
     * Be sure to disable event servicing so we are truly modal.
     */







|








|






|







2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
 *
 * WaitForSocketEvent --
 *
 *	Waits until one of the specified events occurs on a socket.
 *	For event FD_CONNECT use WaitForConnect.
 *
 * Results:
 *	Returns true on success or false on failure, with an error code in
 *	errorCodePtr.
 *
 * Side effects:
 *	Processes socket events off the system queue.
 *
 *----------------------------------------------------------------------
 */

static bool
WaitForSocketEvent(
    TcpState *statePtr,		/* Information about this socket. */
    int events,			/* Events to look for. May be one of
				 * FD_READ or FD_WRITE. */
    int *errorCodePtr)		/* Where to store errors? */
{
    bool result = true;
    int oldMode;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);

    /*
     * Be sure to disable event servicing so we are truly modal.
     */
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937

	/*
	 * Exit loop if event did not occur but this is a non-blocking channel
	 */

	if (statePtr->flags & TCP_NONBLOCKING) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = 0;
	    break;
	}

	/*
	 * Wait until something happens.
	 */








|







2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935

	/*
	 * Exit loop if event did not occur but this is a non-blocking channel
	 */

	if (statePtr->flags & TCP_NONBLOCKING) {
	    *errorCodePtr = EWOULDBLOCK;
	    result = false;
	    break;
	}

	/*
	 * Wait until something happens.
	 */

3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
    UINT message,
    WPARAM wParam,
    LPARAM lParam)
{
    int event, error;
    SOCKET socket;
    TcpState *statePtr;
    int info_found = 0;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
	    GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
	    GetWindowLongW(hwnd, GWL_USERDATA);
#endif








|







3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
    UINT message,
    WPARAM wParam,
    LPARAM lParam)
{
    int event, error;
    SOCKET socket;
    TcpState *statePtr;
    bool info_found = false;
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
	    GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
	    GetWindowLongW(hwnd, GWL_USERDATA);
#endif

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
	 * Find the specified socket on the socket list and update its
	 * eventState flag.
	 */

	for (statePtr = tsdPtr->socketList; statePtr != NULL;
		statePtr = statePtr->nextPtr) {
	    if (FindFDInList(statePtr, socket)) {
		info_found = 1;
		break;
	    }
	}

	/*
	 * Check if there is a pending info structure not jet in the list.
	 */

	if (!info_found
		&& tsdPtr->pendingTcpState != NULL
		&& FindFDInList(tsdPtr->pendingTcpState, socket)) {
	    statePtr = tsdPtr->pendingTcpState;
	    info_found = 1;
	}
	if (info_found) {
	    /*
	     * Update the socket state.
	     *
	     * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
	     * happens, then clear the FD_ACCEPT count. Otherwise, increment







|












|







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
	 * Find the specified socket on the socket list and update its
	 * eventState flag.
	 */

	for (statePtr = tsdPtr->socketList; statePtr != NULL;
		statePtr = statePtr->nextPtr) {
	    if (FindFDInList(statePtr, socket)) {
		info_found = true;
		break;
	    }
	}

	/*
	 * Check if there is a pending info structure not jet in the list.
	 */

	if (!info_found
		&& tsdPtr->pendingTcpState != NULL
		&& FindFDInList(tsdPtr->pendingTcpState, socket)) {
	    statePtr = tsdPtr->pendingTcpState;
	    info_found = true;
	}
	if (info_found) {
	    /*
	     * Update the socket state.
	     *
	     * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event
	     * happens, then clear the FD_ACCEPT count. Otherwise, increment
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
 *	true if found.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
FindFDInList(
    TcpState *statePtr,
    SOCKET socket)
{
    for (TcpFdList *fds = statePtr->sockets; fds != NULL; fds = fds->next) {
	if (fds->fd == socket) {
	    return 1;
	}
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpThreadActionProc --
 *







|






|


|







3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
 *	true if found.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static bool
FindFDInList(
    TcpState *statePtr,
    SOCKET socket)
{
    for (TcpFdList *fds = statePtr->sockets; fds != NULL; fds = fds->next) {
	if (fds->fd == socket) {
	    return true;
	}
    }
    return false;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpThreadActionProc --
 *
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
	    tsdPtr->pendingTcpState = NULL;
	}

	SetEvent(tsdPtr->socketListLock);

	notifyCmd = SELECT;
    } else {
	int removed = 0;

	/*
	 * TIP #218, Bugfix: All access to socketList has to be protected by
	 * the lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (TcpState **nextPtrPtr = &tsdPtr->socketList; *nextPtrPtr != NULL;
		nextPtrPtr = &(*nextPtrPtr)->nextPtr) {
	    if (*nextPtrPtr == statePtr) {
		*nextPtrPtr = statePtr->nextPtr;
		removed = 1;
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);

	/*
	 * This could happen if the channel was created in one thread and then







|











|







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
	    tsdPtr->pendingTcpState = NULL;
	}

	SetEvent(tsdPtr->socketListLock);

	notifyCmd = SELECT;
    } else {
	bool removed = false;

	/*
	 * TIP #218, Bugfix: All access to socketList has to be protected by
	 * the lock.
	 */

	WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
	for (TcpState **nextPtrPtr = &tsdPtr->socketList; *nextPtrPtr != NULL;
		nextPtrPtr = &(*nextPtrPtr)->nextPtr) {
	    if (*nextPtrPtr == statePtr) {
		*nextPtrPtr = statePtr->nextPtr;
		removed = true;
		break;
	    }
	}
	SetEvent(tsdPtr->socketListLock);

	/*
	 * This could happen if the channel was created in one thread and then
Changes to win/tclWinThrd.c.
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

/*
 * This is the global lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION globalLock;
static int initialized = 0;

/*
 * This is the global lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

#if TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
static Tcl_Mutex allocLockPtr = &allocLock;
static int allocOnce = 0;

#endif /* TCL_THREADS */

/*
 * The joinLock serializes Create- and ExitThread. This is necessary to
 * prevent a race where a new joinable thread exits before the creating thread
 * had the time to create the necessary data structures in the emulation







|



















|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

/*
 * This is the global lock used to serialize access to other serialization
 * data structures.
 */

static CRITICAL_SECTION globalLock;
static bool initialized = false;

/*
 * This is the global lock used to serialize initialization and finalization
 * of Tcl as a whole.
 */

static CRITICAL_SECTION initLock;

/*
 * allocLock is used by Tcl's version of malloc for synchronization. For
 * obvious reasons, cannot use any dynamically allocated storage.
 */

#if TCL_THREADS

static struct Tcl_Mutex_ {
    CRITICAL_SECTION crit;
} allocLock;
static Tcl_Mutex allocLockPtr = &allocLock;
static bool allocOnce = false;

#endif /* TCL_THREADS */

/*
 * The joinLock serializes Create- and ExitThread. This is necessary to
 * prevent a race where a new joinable thread exits before the creating thread
 * had the time to create the necessary data structures in the emulation
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	initialized = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&initLock);
}








|







352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	initialized = true;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&initLock);
}

414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	initialized = 1;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&globalLock);
}








|







414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
	/*
	 * There is a fundamental race here that is solved by creating the
	 * first Tcl interpreter in a single threaded environment. Once the
	 * interpreter has been created, it is safe to create more threads
	 * that create interpreters in parallel.
	 */

	initialized = true;
	InitializeCriticalSection(&joinLock);
	InitializeCriticalSection(&initLock);
	InitializeCriticalSection(&globalLock);
    }
    EnterCriticalSection(&globalLock);
}

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484

Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
#if TCL_THREADS
    if (!allocOnce) {
	InitializeCriticalSection(&allocLock.crit);
	allocOnce = 1;
    }
    return &allocLockPtr;
#else
    return NULL;
#endif
}








|







470
471
472
473
474
475
476
477
478
479
480
481
482
483
484

Tcl_Mutex *
Tcl_GetAllocMutex(void)
{
#if TCL_THREADS
    if (!allocOnce) {
	InitializeCriticalSection(&allocLock.crit);
	allocOnce = true;
    }
    return &allocLockPtr;
#else
    return NULL;
#endif
}

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&globalLock);
    initialized = 0;

#if TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = 0;
    }
#endif

    LeaveCriticalSection(&initLock);

    /*
     * Destroy the critical section that we were holding.







|




|







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    DeleteCriticalSection(&joinLock);

    /*
     * Destroy the critical section that we are holding!
     */

    DeleteCriticalSection(&globalLock);
    initialized = false;

#if TCL_THREADS
    if (allocOnce) {
	DeleteCriticalSection(&allocLock.crit);
	allocOnce = false;
    }
#endif

    LeaveCriticalSection(&initLock);

    /*
     * Destroy the critical section that we were holding.
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
    Tcl_Condition *condPtr,	/* Really (WinCondition **) */
    Tcl_Mutex *mutexPtr,	/* Really (CRITICAL_SECTION **) */
    const Tcl_Time *timePtr)	/* Timeout on waiting period */
{
    WinCondition *winCondPtr;	/* Per-condition queue head */
    CRITICAL_SECTION *csPtr;	/* Caller's Mutex, after casting */
    DWORD wtime;		/* Windows time value */
    int timeout;		/* True if we got a timeout */
    int doExit = 0;		/* True if we need to do exit setup */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	TclpGlobalLock();

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = 1;
	}
	TclpGlobalUnlock();

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Global Lock because







|
|




















|







658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
    Tcl_Condition *condPtr,	/* Really (WinCondition **) */
    Tcl_Mutex *mutexPtr,	/* Really (CRITICAL_SECTION **) */
    const Tcl_Time *timePtr)	/* Timeout on waiting period */
{
    WinCondition *winCondPtr;	/* Per-condition queue head */
    CRITICAL_SECTION *csPtr;	/* Caller's Mutex, after casting */
    DWORD wtime;		/* Windows time value */
    bool timeout;		/* True if we got a timeout */
    bool doExit = false;	/* True if we need to do exit setup */
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Self initialize the two parts of the condition. The per-condition and
     * per-thread parts need to be handled independently.
     */

    if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	TclpGlobalLock();

	/*
	 * Create the per-thread event and queue pointers.
	 */

	if (tsdPtr->flags == WIN_THREAD_UNINIT) {
	    tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
		    FALSE /* non signaled */, NULL);
	    tsdPtr->nextPtr = NULL;
	    tsdPtr->prevPtr = NULL;
	    tsdPtr->flags = WIN_THREAD_RUNNING;
	    doExit = true;
	}
	TclpGlobalUnlock();

	if (doExit) {
	    /*
	     * Create a per-thread exit handler to clean up the condEvent. We
	     * must be careful to do this outside the Global Lock because
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
     * In that race condition we'll wait again for the full timeout. Timed
     * waits are dubious anyway. Either you have the locking protocol wrong
     * and are masking a deadlock, or you are using conditions to pause your
     * thread.
     */

    LeaveCriticalSection(csPtr);
    timeout = 0;
    while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
	ResetEvent(tsdPtr->condEvent);
	LeaveCriticalSection(&winCondPtr->condLock);
	if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime,
		TRUE) == WAIT_TIMEOUT) {
	    timeout = 1;
	}
	EnterCriticalSection(&winCondPtr->condLock);
    }

    /*
     * Be careful on timeouts because the signal might arrive right around the
     * time limit and someone else could have taken us off the queue.
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = 0;
	} else {
	    /*
	     * When dequeueing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialized w/out reading them when the thread is enqueued
	     * later.
	     */







|





|











|







749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
     * In that race condition we'll wait again for the full timeout. Timed
     * waits are dubious anyway. Either you have the locking protocol wrong
     * and are masking a deadlock, or you are using conditions to pause your
     * thread.
     */

    LeaveCriticalSection(csPtr);
    timeout = false;
    while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
	ResetEvent(tsdPtr->condEvent);
	LeaveCriticalSection(&winCondPtr->condLock);
	if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime,
		TRUE) == WAIT_TIMEOUT) {
	    timeout = true;
	}
	EnterCriticalSection(&winCondPtr->condLock);
    }

    /*
     * Be careful on timeouts because the signal might arrive right around the
     * time limit and someone else could have taken us off the queue.
     */

    if (timeout) {
	if (tsdPtr->flags & WIN_THREAD_RUNNING) {
	    timeout = false;
	} else {
	    /*
	     * When dequeueing, we can leave the tsdPtr->nextPtr and
	     * tsdPtr->prevPtr with dangling pointers because they are
	     * reinitialized w/out reading them when the thread is enqueued
	     * later.
	     */
Changes to win/tclWinTime.c.
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

/*
 * Data for managing high-resolution timers.
 */

typedef struct {
    CRITICAL_SECTION cs;	/* Mutex guarding this structure. */
    int initialized;		/* Flag == 1 if this structure is
				 * initialized. */
    int perfCounterAvailable;	/* Flag == 1 if the hardware has a performance
				 * counter. */
    DWORD calibrationInterv;	/* Calibration interval in seconds (start 1
				 * sec) */
    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */
    HANDLE readyEvent;		/* System event used to trigger the requesting
				 * thread when the clock calibration procedure







|
<
|







20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35

/*
 * Data for managing high-resolution timers.
 */

typedef struct {
    CRITICAL_SECTION cs;	/* Mutex guarding this structure. */
    bool initialized;		/* True if this structure is initialized. */

    bool perfCounterAvailable;	/* True if the hardware has a performance
				 * counter. */
    DWORD calibrationInterv;	/* Calibration interval in seconds (start 1
				 * sec) */
    HANDLE calibrationThread;	/* Handle to the thread that keeps the virtual
				 * clock calibrated. */
    HANDLE readyEvent;		/* System event used to trigger the requesting
				 * thread when the clock calibration procedure
64
65
66
67
68
69
70
71
72


73
74
75
76
77
78
79
    long long perfCounterSample[SAMPLES];
				/* Last 64 samples of performance counter. */
    int sampleNo;		/* Current sample number. */
} TimeInfo;

static TimeInfo timeInfo = {
    { NULL, 0, 0, NULL, NULL, 0 },
    0,
    0,


    1,
    (HANDLE) NULL,
    (HANDLE) NULL,
    (HANDLE) NULL,
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
    (LARGE_INTEGER) (long long) 0,
    (ULARGE_INTEGER) (DWORDLONG) 0,







<
<
>
>







63
64
65
66
67
68
69


70
71
72
73
74
75
76
77
78
    long long perfCounterSample[SAMPLES];
				/* Last 64 samples of performance counter. */
    int sampleNo;		/* Current sample number. */
} TimeInfo;

static TimeInfo timeInfo = {
    { NULL, 0, 0, NULL, NULL, 0 },


    false,
    false,
    1,
    (HANDLE) NULL,
    (HANDLE) NULL,
    (HANDLE) NULL,
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
    (LARGE_INTEGER) (long long) 0,
    (ULARGE_INTEGER) (DWORDLONG) 0,
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
};

/*
 * Scale to convert wide click values from the TclpGetWideClicks native
 * resolution to microsecond resolution and back.
 */
static struct {
    int initialized;		/* 1 if initialized, 0 otherwise */
    int perfCounter;		/* 1 if performance counter usable for wide
				 * clicks */
    double microsecsScale;	/* Denominator scale between clock / microsecs */
} wideClick = {0, 0, 0.0};

/*
 * Declarations for functions defined later in this file.
 */







|
|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
};

/*
 * Scale to convert wide click values from the TclpGetWideClicks native
 * resolution to microsecond resolution and back.
 */
static struct {
    bool initialized;		/* true if initialized, false otherwise */
    bool perfCounter;		/* true if performance counter usable for wide
				 * clicks */
    double microsecsScale;	/* Denominator scale between clock / microsecs */
} wideClick = {0, 0, 0.0};

/*
 * Declarations for functions defined later in this file.
 */
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
	/*
	 * The frequency of the performance counter is fixed at system boot and
	 * is consistent across all processors. Therefore, the frequency need
	 * only be queried upon application initialization.
	 */

	if (QueryPerformanceFrequency(&perfCounterFreq)) {
	    wideClick.perfCounter = 1;
	    wideClick.microsecsScale = 1000000.0 / (double)perfCounterFreq.QuadPart;
	} else {
	    /* fallback using microseconds */
	    wideClick.perfCounter = 0;
	    wideClick.microsecsScale = 1;
	}

	wideClick.initialized = 1;
    }
    if (wideClick.perfCounter) {
	if (QueryPerformanceCounter(&curCounter)) {
	    return (long long)curCounter.QuadPart;
	}
	/* fallback using microseconds */
	wideClick.perfCounter = 0;
	wideClick.microsecsScale = 1;
	return TclpGetMicroseconds();
    } else {
	return TclpGetMicroseconds();
    }
}








|



|



|






|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
	/*
	 * The frequency of the performance counter is fixed at system boot and
	 * is consistent across all processors. Therefore, the frequency need
	 * only be queried upon application initialization.
	 */

	if (QueryPerformanceFrequency(&perfCounterFreq)) {
	    wideClick.perfCounter = true;
	    wideClick.microsecsScale = 1000000.0 / (double)perfCounterFreq.QuadPart;
	} else {
	    /* fallback using microseconds */
	    wideClick.perfCounter = false;
	    wideClick.microsecsScale = 1;
	}

	wideClick.initialized = true;
    }
    if (wideClick.perfCounter) {
	if (QueryPerformanceCounter(&curCounter)) {
	    return (long long)curCounter.QuadPart;
	}
	/* fallback using microseconds */
	wideClick.perfCounter = false;
	wideClick.microsecsScale = 1;
	return TclpGetMicroseconds();
    } else {
	return TclpGetMicroseconds();
    }
}

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
 * IsPerfCounterAvailable --
 *
 *	Tests whether the performance counter is available, which is a gnarly
 *	problem on 32-bit systems. Also retrieves the nominal frequency of the
 *	performance counter.
 *
 * Results:
 *	1 if the counter is available, 0 if not.
 *
 * Side effects:
 *	Updates fields of the timeInfo global. Make sure you hold the lock
 *	before calling this.
 *
 *----------------------------------------------------------------------
 */

static inline int
IsPerfCounterAvailable(void)
{
    timeInfo.perfCounterAvailable =
	    QueryPerformanceFrequency(&timeInfo.nominalFreq);

    /*
     * Some hardware abstraction layers use the CPU clock in place of the







|








|







422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
 * IsPerfCounterAvailable --
 *
 *	Tests whether the performance counter is available, which is a gnarly
 *	problem on 32-bit systems. Also retrieves the nominal frequency of the
 *	performance counter.
 *
 * Results:
 *	true if the counter is available, false if not.
 *
 * Side effects:
 *	Updates fields of the timeInfo global. Make sure you hold the lock
 *	before calling this.
 *
 *----------------------------------------------------------------------
 */

static inline bool
IsPerfCounterAvailable(void)
{
    timeInfo.perfCounterAvailable =
	    QueryPerformanceFrequency(&timeInfo.nominalFreq);

    /*
     * Some hardware abstraction layers use the CPU clock in place of the
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
		&& regs[2] == 0x6C65746E	/* "ntel" */
		&& TclWinCPUID(1, regs) == TCL_OK
		&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
		|| ((regs[0] & 0x00F00000)	/* Extended family */
		&& (regs[3] & 0x10000000)))	/* Hyperthread */
		&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
			== (int)systemInfo.dwNumberOfProcessors)) {
	    timeInfo.perfCounterAvailable = TRUE;
	} else {
	    timeInfo.perfCounterAvailable = FALSE;
	}
    }
#endif /* above code is Win32 only */

    return timeInfo.perfCounterAvailable;
}








|

|







492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
		&& regs[2] == 0x6C65746E	/* "ntel" */
		&& TclWinCPUID(1, regs) == TCL_OK
		&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
		|| ((regs[0] & 0x00F00000)	/* Extended family */
		&& (regs[3] & 0x10000000)))	/* Hyperthread */
		&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
			== (int)systemInfo.dwNumberOfProcessors)) {
	    timeInfo.perfCounterAvailable = true;
	} else {
	    timeInfo.perfCounterAvailable = false;
	}
    }
#endif /* above code is Win32 only */

    return timeInfo.perfCounterAvailable;
}

886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */

    if (timeInfo.curCounterFreq.QuadPart == 0){
	timeInfo.perfCounterAvailable = 0;
	return;
    }

    /*
     * Several things may have gone wrong here that have to be checked for.
     *  (1) The performance counter may have jumped.
     *  (2) The system clock may have been reset.







|







885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
     * it is good to be defensive about such matters. So if something goes
     * wrong and the value does goes to zero, we clear the
     * timeInfo.perfCounterAvailable in order to cause the calibration thread
     * to shut itself down, then return without additional processing.
     */

    if (timeInfo.curCounterFreq.QuadPart == 0){
	timeInfo.perfCounterAvailable = false;
	return;
    }

    /*
     * Several things may have gone wrong here that have to be checked for.
     *  (1) The performance counter may have jumped.
     *  (2) The system clock may have been reset.