Tcl Source Code

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

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

Overview
Comment:Reap the simplifications brought by the previous bugfix.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bg-tip-282
Files: files | file ages | folders
SHA1: cccdc6565052eb090627fe6b444707025928e6d3
User & Date: ferrieux 2017-02-26 13:47:28
Context
2017-02-27
15:19
merge trunk check-in: 5fb0e5ebc8 user: dgp tags: bg-tip-282
2017-02-26
22:13
Merged Alexandre Ferrieux's bugfix. check-in: b1cfc2126b user: avl tags: avl-tip-282
13:47
Reap the simplifications brought by the previous bugfix. check-in: cccdc65650 user: ferrieux tags: bg-tip-282
2017-02-25
22:42
Fix a 2002 bug detected by Brian Griffin : in the presence of [], ParseTokens overshoots the passed ... check-in: e5800b67f9 user: ferrieux tags: bg-tip-282
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCompExpr.c.

983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
		    errCode = "BADCHAR";
		    goto error;
		}
		scanned = tokenPtr->size;
		break;

	    case VARNAME:
		code = TclParseTokens(NULL, start, scanned, TCL_SUBST_ALL, 1, 
				      parsePtr);

		// scanned already adjusted...
		break;

	    case SCRIPT: {
		Tcl_Parse *nestedPtr =
			TclStackAlloc(interp, sizeof(Tcl_Parse));






|
<







983
984
985
986
987
988
989
990

991
992
993
994
995
996
997
		    errCode = "BADCHAR";
		    goto error;
		}
		scanned = tokenPtr->size;
		break;

	    case VARNAME:
		code = TclParseTokens(start, scanned, /* mask */ 0, TCL_SUBST_ALL,  parsePtr);


		// scanned already adjusted...
		break;

	    case SCRIPT: {
		Tcl_Parse *nestedPtr =
			TclStackAlloc(interp, sizeof(Tcl_Parse));

Changes to generic/tclInt.h.

3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
			    int *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    const char *expected, const char *bytes,
			    int numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    int numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE int	TclParseAllWhiteSpace(const char *src, int numBytes);
MODULE_SCOPE int	TclParseTokens(Tcl_Interp *interp, const char *bytes,
			    int numBytes, int flags, int append, Tcl_Parse *parsePtr);
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *  TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    int len);






|
|







3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
			    int *resultPtr);
MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
			    const char *expected, const char *bytes,
			    int numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
			    int numBytes, Tcl_Parse *parsePtr);
MODULE_SCOPE int	TclParseAllWhiteSpace(const char *src, int numBytes);
MODULE_SCOPE int	TclParseTokens(const char *src, int numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
			    int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj *	TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj *  TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj *	TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
			    int len);

Changes to generic/tclParse.c.

31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
...
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
....
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
....
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
....
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
....
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
....
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
....
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
....
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
....
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
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
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
 *
 * TYPE_NORMAL -	All characters that don't have special significance to
 *			the Tcl parser.
 * TYPE_SPACE -		The character is a whitespace character other than
 *			newline.
 * TYPE_COMMAND_END -	Character is newline or semicolon.
 * TYPE_SUBS -		Character begins a substitution or has other special
 *			meaning in ParseTokens: backslash, dollar sign, or
 *			open bracket.
 * TYPE_QUOTE -		Character is a double quote.
 * TYPE_CLOSE_PAREN -	Character is a right parenthesis.
 * TYPE_CLOSE_BRACK -	Character is a right square bracket.
 * TYPE_BRACE -		Character is a curly brace (either left or right).
 */

................................................................................
/*
 * Prototypes for local functions defined in this file:
 */

static inline int	CommandComplete(const char *script, int numBytes);
static int		ParseComment(const char *src, int numBytes,
			    Tcl_Parse *parsePtr);
static int		ParseTokens(const char *src, int numBytes, int mask,
			    int flags, Tcl_Parse *parsePtr);
static int		ParseWhiteSpace(const char *src, int numBytes,
			    int *incompletePtr, char *typePtr);
static int		ParseAllWhiteSpace(const char *src, int numBytes,
			    int *incompletePtr);
 
/*
 *----------------------------------------------------------------------
................................................................................
		    /* 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.
	     */

	    if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
		    TCL_SUBST_ALL, parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term;
	    numBytes = parsePtr->end - src;
	}

................................................................................
    parsePtr->incomplete = incomplete;
    return (p - src);
}
 
/*
 *----------------------------------------------------------------------
 *
 * ParseTokens --
 *
 *	This function forms the heart of the Tcl parser. It parses one or more
 *	tokens from a string, up to a termination point specified by the
 *	caller. This function is used to parse unquoted command words (those
 *	not in quotes or braces), words in quotes, and array indices for
 *	variables. No more than numBytes bytes will be scanned.
 *
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(
    register const char *src,	/* First character to parse. */
    register int numBytes,	/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
................................................................................
	} else if (*src == 0) {
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;
	    src++;
	    numBytes--;
	} else {
	    Tcl_Panic("ParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text. Add an empty token for the
	 * empty range, so that there is always at least one token added.
	 */
................................................................................
	tokenPtr->size = src - tokenPtr->start;
	if ((tokenPtr->size == 0) && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element. Call ParseTokens
	     * recursively to parse the element name, since it could contain
	     * any number of substitutions.
	     */

	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "missing )", -1));
................................................................................
	numBytes = strlen(start);
    }

    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }

    if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
	    parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
		    "missing \"", -1));
................................................................................

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively
     * inhibit types of substitution.
     */

    if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
	/*
	 * There was a parse error. Save the interpreter state for possible
	 * error reporting later.
	 */

	*statePtr = Tcl_SaveInterpState(interp, TCL_ERROR);

................................................................................
	 * We need to re-parse to get the portion of the string we can [subst]
	 * before the parse error. Sadly, all the Tcl_Token's created by the
	 * first parse attempt are gone, freed according to the public spec
	 * for the Tcl_Parse* routines. The only clue we have is parse.term,
	 * which points to either the unmatched opener, or to characters that
	 * follow a close brace or close quote.
	 *
	 * Call ParseTokens again, working on the string up to parse.term.
	 * 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 [.
	 */

	switch (*(parsePtr->term)) {
	case '{':
................................................................................
				 * check. */
{
    int length;
    const char *script = TclGetStringFromObj(objPtr, &length);

    return CommandComplete(script, length);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclParseTokens --
 *
 *	Token parser used by ParseExpr. Parses the string made up of
 *	'numBytes' bytes starting at 'bytes'. Parsing is controlled by the
 *	flags argument to limit which substitutions to apply, as 
 *	represented by the flag values TCL_SUBST_BACKSLASHES, 
 *	TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES.
 *
 * Results:
 *	Tokens are added to parsePtr and parsePtr->term is filled in with the
 *	address of the character that terminated the parse (the character at 
 *	parsePtr->end). The return value is TCL_OK if the parse completed 
 *	successfully and TCL_ERROR otherwise. If a parse error occurs and 
 *	parsePtr->interp is not NULL, then an error message is left in the 
 *	interpreter's result.
 *
 * Side effects:
 *	The Tcl_Parse struct '*parsePtr' is filled with parse results.
 *	The caller is expected to eventually call Tcl_FreeParse() to properly
 *	cleanup the value written there.
 *
 *	If a parse error occurs, the Tcl_InterpState value '*statePtr' is
 *	filled with the state created by that error. When *statePtr is written
 *	to, the caller is expected to make the required calls to either
 *	Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the
 *	value written there.
 *
 *----------------------------------------------------------------------
 */

int
TclParseTokens(
    Tcl_Interp *interp,
    const char *bytes,
    int numBytes,
    int flags,
    int append,
    Tcl_Parse *parsePtr)
{
    int length = numBytes;
    const char *p = bytes;
    int code, offset, i;
    int startToken;

    if (!append) {
	TclParseInit(interp, p, length, parsePtr);
    }

    startToken = parsePtr->numTokens;

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively
     * inhibit types of substitution.
     */

    code = ParseTokens(p, length, /* mask */ 0, flags, parsePtr);
    /* Truncate last token to length */
    /* Hack?  Why does ParseTokens not stop at numBytes? */
    for (i=startToken; i<parsePtr->numTokens; i++) {
	offset = parsePtr->tokenPtr[i].start - p + parsePtr->tokenPtr[i].size;
	if (offset >= length) break;
    }
    if (offset > length) {
	parsePtr->tokenPtr[i].size = length - (parsePtr->tokenPtr[i].start - p);
	/* Truncate tokens */
	if (i < parsePtr->numTokens) 
	    parsePtr->numTokens = i + 1;
    }
    return code;
}

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






|







 







<
<







 







|



|







 







|







 







|
|







 







|







 







|




|







 







|







 







|







 







|










|







 









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
159
160
161
162
163
164
165


166
167
168
169
170
171
172
...
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
....
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
....
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
....
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
....
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
....
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
....
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
....
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
....
2497
2498
2499
2500
2501
2502
2503
2504
2505












































































2506
2507
2508
2509
2510
2511
 *
 * TYPE_NORMAL -	All characters that don't have special significance to
 *			the Tcl parser.
 * TYPE_SPACE -		The character is a whitespace character other than
 *			newline.
 * TYPE_COMMAND_END -	Character is newline or semicolon.
 * TYPE_SUBS -		Character begins a substitution or has other special
 *			meaning in TclParseTokens: backslash, dollar sign, or
 *			open bracket.
 * TYPE_QUOTE -		Character is a double quote.
 * TYPE_CLOSE_PAREN -	Character is a right parenthesis.
 * TYPE_CLOSE_BRACK -	Character is a right square bracket.
 * TYPE_BRACE -		Character is a curly brace (either left or right).
 */

................................................................................
/*
 * Prototypes for local functions defined in this file:
 */

static inline int	CommandComplete(const char *script, int numBytes);
static int		ParseComment(const char *src, int numBytes,
			    Tcl_Parse *parsePtr);


static int		ParseWhiteSpace(const char *src, int numBytes,
			    int *incompletePtr, char *typePtr);
static int		ParseAllWhiteSpace(const char *src, int numBytes,
			    int *incompletePtr);
 
/*
 *----------------------------------------------------------------------
................................................................................
		    /* Non-whitespace follows */) {
		expandWord = 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call TclParseTokens and let it do all of
	     * the work.
	     */

	    if (TclParseTokens(src, numBytes, TYPE_SPACE|terminators,
		    TCL_SUBST_ALL, parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term;
	    numBytes = parsePtr->end - src;
	}

................................................................................
    parsePtr->incomplete = incomplete;
    return (p - src);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclParseTokens --
 *
 *	This function forms the heart of the Tcl parser. It parses one or more
 *	tokens from a string, up to a termination point specified by the
 *	caller. This function is used to parse unquoted command words (those
 *	not in quotes or braces), words in quotes, and array indices for
 *	variables. No more than numBytes bytes will be scanned.
 *
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseTokens(
    register const char *src,	/* First character to parse. */
    register int numBytes,	/* Max number of bytes to scan. */
    int mask,			/* Specifies when to stop parsing. The parse
				 * stops at the first unquoted character whose
				 * CHAR_TYPE contains any of the bits in
				 * mask. */
    int flags,			/* OR-ed bits indicating what substitutions to
................................................................................
	} else if (*src == 0) {
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;
	    src++;
	    numBytes--;
	} else {
	    Tcl_Panic("TclParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text. Add an empty token for the
	 * empty range, so that there is always at least one token added.
	 */
................................................................................
	tokenPtr->size = src - tokenPtr->start;
	if ((tokenPtr->size == 0) && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element. Call TclParseTokens
	     * recursively to parse the element name, since it could contain
	     * any number of substitutions.
	     */

	    if (TCL_OK != TclParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
		    TCL_SUBST_ALL, parsePtr)) {
		goto error;
	    }
	    if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
		if (parsePtr->interp != NULL) {
		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
			    "missing )", -1));
................................................................................
	numBytes = strlen(start);
    }

    if (!append) {
	TclParseInit(interp, start, numBytes, parsePtr);
    }

    if (TCL_OK != TclParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
	    parsePtr)) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (parsePtr->interp != NULL) {
	    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
		    "missing \"", -1));
................................................................................

    /*
     * First parse the string rep of objPtr, as if it were enclosed as a
     * "-quoted word in a normal Tcl command. Honor flags that selectively
     * inhibit types of substitution.
     */

    if (TCL_OK != TclParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
	/*
	 * There was a parse error. Save the interpreter state for possible
	 * error reporting later.
	 */

	*statePtr = Tcl_SaveInterpState(interp, TCL_ERROR);

................................................................................
	 * We need to re-parse to get the portion of the string we can [subst]
	 * before the parse error. Sadly, all the Tcl_Token's created by the
	 * first parse attempt are gone, freed according to the public spec
	 * for the Tcl_Parse* routines. The only clue we have is parse.term,
	 * which points to either the unmatched opener, or to characters that
	 * follow a close brace or close quote.
	 *
	 * Call TclParseTokens again, working on the string up to parse.term.
	 * 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 !=
		TclParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));

	/*
	 * The good parse will have to be followed by {, (, or [.
	 */

	switch (*(parsePtr->term)) {
	case '{':
................................................................................
				 * check. */
{
    int length;
    const char *script = TclGetStringFromObj(objPtr, &length);

    return CommandComplete(script, length);
}
 
/*












































































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