Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclParse.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclParse.c --
sl@0	3	*
sl@0	4	* This file contains procedures that parse Tcl scripts. They
sl@0	5	* do so in a general-purpose fashion that can be used for many
sl@0	6	* different purposes, including compilation, direct execution,
sl@0	7	* code analysis, etc.
sl@0	8	*
sl@0	9	* Copyright (c) 1997 Sun Microsystems, Inc.
sl@0	10	* Copyright (c) 1998-2000 Ajuba Solutions.
sl@0	11	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	12	* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
sl@0	13	*
sl@0	14	* See the file "license.terms" for information on usage and redistribution
sl@0	15	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	16	*
sl@0	17	* RCS: @(#) $Id: tclParse.c,v 1.25.2.1 2006/09/24 21:15:10 msofer Exp $
sl@0	18	*/
sl@0	19
sl@0	20	#include "tclInt.h"
sl@0	21	#include "tclPort.h"
sl@0	22
sl@0	23	/*
sl@0	24	* The following table provides parsing information about each possible
sl@0	25	* 8-bit character. The table is designed to be referenced with either
sl@0	26	* signed or unsigned characters, so it has 384 entries. The first 128
sl@0	27	* entries correspond to negative character values, the next 256 correspond
sl@0	28	* to positive character values. The last 128 entries are identical to the
sl@0	29	* first 128. The table is always indexed with a 128-byte offset (the 128th
sl@0	30	* entry corresponds to a character value of 0).
sl@0	31	*
sl@0	32	* The macro CHAR_TYPE is used to index into the table and return
sl@0	33	* information about its character argument. The following return
sl@0	34	* values are defined.
sl@0	35	*
sl@0	36	* TYPE_NORMAL - All characters that don't have special significance
sl@0	37	* to the Tcl parser.
sl@0	38	* TYPE_SPACE - The character is a whitespace character other
sl@0	39	* than newline.
sl@0	40	* TYPE_COMMAND_END - Character is newline or semicolon.
sl@0	41	* TYPE_SUBS - Character begins a substitution or has other
sl@0	42	* special meaning in ParseTokens: backslash, dollar
sl@0	43	* sign, or open bracket.
sl@0	44	* TYPE_QUOTE - Character is a double quote.
sl@0	45	* TYPE_CLOSE_PAREN - Character is a right parenthesis.
sl@0	46	* TYPE_CLOSE_BRACK - Character is a right square bracket.
sl@0	47	* TYPE_BRACE - Character is a curly brace (either left or right).
sl@0	48	*/
sl@0	49
sl@0	50	#define TYPE_NORMAL 0
sl@0	51	#define TYPE_SPACE 0x1
sl@0	52	#define TYPE_COMMAND_END 0x2
sl@0	53	#define TYPE_SUBS 0x4
sl@0	54	#define TYPE_QUOTE 0x8
sl@0	55	#define TYPE_CLOSE_PAREN 0x10
sl@0	56	#define TYPE_CLOSE_BRACK 0x20
sl@0	57	#define TYPE_BRACE 0x40
sl@0	58
sl@0	59	#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
sl@0	60
sl@0	61	static CONST char charTypeTable[] = {
sl@0	62	/*
sl@0	63	* Negative character values, from -128 to -1:
sl@0	64	*/
sl@0	65
sl@0	66	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	67	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	68	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	69	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	70	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	71	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	72	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	73	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	74	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	75	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	76	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	77	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	78	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	79	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	80	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	81	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	82	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	83	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	84	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	85	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	86	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	87	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	88	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	89	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	90	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	91	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	92	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	93	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	94	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	95	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	96	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	97	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	98
sl@0	99	/*
sl@0	100	* Positive character values, from 0-127:
sl@0	101	*/
sl@0	102
sl@0	103	TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	104	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	105	TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
sl@0	106	TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
sl@0	107	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	108	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	109	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	110	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	111	TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
sl@0	112	TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	113	TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL,
sl@0	114	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	115	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	116	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	117	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END,
sl@0	118	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	119	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	120	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	121	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	122	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	123	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	124	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	125	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS,
sl@0	126	TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
sl@0	127	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	128	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	129	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	130	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	131	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	132	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	133	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
sl@0	134	TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
sl@0	135
sl@0	136	/*
sl@0	137	* Large unsigned character values, from 128-255:
sl@0	138	*/
sl@0	139
sl@0	140	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	141	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	142	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	143	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	144	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	145	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	146	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	147	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	148	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	149	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	150	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	151	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	152	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	153	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	154	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	155	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	156	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	157	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	158	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	159	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	160	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	161	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	162	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	163	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	164	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	165	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	166	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	167	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	168	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	169	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	170	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	171	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
sl@0	172	};
sl@0	173
sl@0	174	/*
sl@0	175	* Prototypes for local procedures defined in this file:
sl@0	176	*/
sl@0	177
sl@0	178	static int CommandComplete _ANSI_ARGS_((CONST char *script,
sl@0	179	int numBytes));
sl@0	180	static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
sl@0	181	Tcl_Parse *parsePtr));
sl@0	182	static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
sl@0	183	int mask, Tcl_Parse *parsePtr));
sl@0	184
sl@0	185	/*
sl@0	186	*----------------------------------------------------------------------
sl@0	187	*
sl@0	188	* Tcl_ParseCommand --
sl@0	189	*
sl@0	190	* Given a string, this procedure parses the first Tcl command
sl@0	191	* in the string and returns information about the structure of
sl@0	192	* the command.
sl@0	193	*
sl@0	194	* Results:
sl@0	195	* The return value is TCL_OK if the command was parsed
sl@0	196	* successfully and TCL_ERROR otherwise. If an error occurs
sl@0	197	* and interp isn't NULL then an error message is left in
sl@0	198	* its result. On a successful return, parsePtr is filled in
sl@0	199	* with information about the command that was parsed.
sl@0	200	*
sl@0	201	* Side effects:
sl@0	202	* If there is insufficient space in parsePtr to hold all the
sl@0	203	* information about the command, then additional space is
sl@0	204	* malloc-ed. If the procedure returns TCL_OK then the caller must
sl@0	205	* eventually invoke Tcl_FreeParse to release any additional space
sl@0	206	* that was allocated.
sl@0	207	*
sl@0	208	*----------------------------------------------------------------------
sl@0	209	*/
sl@0	210
sl@0	211	EXPORT_C int
sl@0	212	Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
sl@0	213	Tcl_Interp interp; / Interpreter to use for error reporting;
sl@0	214	* if NULL, then no error message is
sl@0	215	* provided. */
sl@0	216	CONST char string; / First character of string containing
sl@0	217	* one or more Tcl commands. */
sl@0	218	register int numBytes; /* Total number of bytes in string. If < 0,
sl@0	219	* the script consists of all bytes up to
sl@0	220	* the first null character. */
sl@0	221	int nested; /* Non-zero means this is a nested command:
sl@0	222	* close bracket should be considered
sl@0	223	* a command terminator. If zero, then close
sl@0	224	* bracket has no special meaning. */
sl@0	225	register Tcl_Parse *parsePtr;
sl@0	226	/* Structure to fill in with information
sl@0	227	* about the parsed command; any previous
sl@0	228	* information in the structure is
sl@0	229	* ignored. */
sl@0	230	{
sl@0	231	register CONST char src; / Points to current character
sl@0	232	* in the command. */
sl@0	233	char type; /* Result returned by CHAR_TYPE(src). /
sl@0	234	Tcl_Token tokenPtr; / Pointer to token being filled in. */
sl@0	235	int wordIndex; /* Index of word token for current word. */
sl@0	236	int terminators; /* CHAR_TYPE bits that indicate the end
sl@0	237	* of a command. */
sl@0	238	CONST char termPtr; / Set by Tcl_ParseBraces/QuotedString to
sl@0	239	* point to char after terminating one. */
sl@0	240	int scanned;
sl@0	241
sl@0	242	if ((string == NULL) && (numBytes!=0)) {
sl@0	243	if (interp != NULL) {
sl@0	244	Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
sl@0	245	}
sl@0	246	return TCL_ERROR;
sl@0	247	}
sl@0	248	if (numBytes < 0) {
sl@0	249	numBytes = strlen(string);
sl@0	250	}
sl@0	251	parsePtr->commentStart = NULL;
sl@0	252	parsePtr->commentSize = 0;
sl@0	253	parsePtr->commandStart = NULL;
sl@0	254	parsePtr->commandSize = 0;
sl@0	255	parsePtr->numWords = 0;
sl@0	256	parsePtr->tokenPtr = parsePtr->staticTokens;
sl@0	257	parsePtr->numTokens = 0;
sl@0	258	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
sl@0	259	parsePtr->string = string;
sl@0	260	parsePtr->end = string + numBytes;
sl@0	261	parsePtr->term = parsePtr->end;
sl@0	262	parsePtr->interp = interp;
sl@0	263	parsePtr->incomplete = 0;
sl@0	264	parsePtr->errorType = TCL_PARSE_SUCCESS;
sl@0	265	if (nested != 0) {
sl@0	266	terminators = TYPE_COMMAND_END \| TYPE_CLOSE_BRACK;
sl@0	267	} else {
sl@0	268	terminators = TYPE_COMMAND_END;
sl@0	269	}
sl@0	270
sl@0	271	/*
sl@0	272	* Parse any leading space and comments before the first word of the
sl@0	273	* command.
sl@0	274	*/
sl@0	275
sl@0	276	scanned = ParseComment(string, numBytes, parsePtr);
sl@0	277	src = (string + scanned); numBytes -= scanned;
sl@0	278	if (numBytes == 0) {
sl@0	279	if (nested) {
sl@0	280	parsePtr->incomplete = nested;
sl@0	281	}
sl@0	282	}
sl@0	283
sl@0	284	/*
sl@0	285	* The following loop parses the words of the command, one word
sl@0	286	* in each iteration through the loop.
sl@0	287	*/
sl@0	288
sl@0	289	parsePtr->commandStart = src;
sl@0	290	while (1) {
sl@0	291	/*
sl@0	292	* Create the token for the word.
sl@0	293	*/
sl@0	294
sl@0	295	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
sl@0	296	TclExpandTokenArray(parsePtr);
sl@0	297	}
sl@0	298	wordIndex = parsePtr->numTokens;
sl@0	299	tokenPtr = &parsePtr->tokenPtr[wordIndex];
sl@0	300	tokenPtr->type = TCL_TOKEN_WORD;
sl@0	301
sl@0	302	/*
sl@0	303	* Skip white space before the word. Also skip a backslash-newline
sl@0	304	* sequence: it should be treated just like white space.
sl@0	305	*/
sl@0	306
sl@0	307	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
sl@0	308	src += scanned; numBytes -= scanned;
sl@0	309	if (numBytes == 0) {
sl@0	310	parsePtr->term = src;
sl@0	311	break;
sl@0	312	}
sl@0	313	if ((type & terminators) != 0) {
sl@0	314	parsePtr->term = src;
sl@0	315	src++;
sl@0	316	break;
sl@0	317	}
sl@0	318	tokenPtr->start = src;
sl@0	319	parsePtr->numTokens++;
sl@0	320	parsePtr->numWords++;
sl@0	321
sl@0	322	/*
sl@0	323	* At this point the word can have one of three forms: something
sl@0	324	* enclosed in quotes, something enclosed in braces, or an
sl@0	325	* unquoted word (anything else).
sl@0	326	*/
sl@0	327
sl@0	328	if (*src == '"') {
sl@0	329	if (Tcl_ParseQuotedString(interp, src, numBytes,
sl@0	330	parsePtr, 1, &termPtr) != TCL_OK) {
sl@0	331	goto error;
sl@0	332	}
sl@0	333	src = termPtr; numBytes = parsePtr->end - src;
sl@0	334	} else if (*src == '{') {
sl@0	335	if (Tcl_ParseBraces(interp, src, numBytes,
sl@0	336	parsePtr, 1, &termPtr) != TCL_OK) {
sl@0	337	goto error;
sl@0	338	}
sl@0	339	src = termPtr; numBytes = parsePtr->end - src;
sl@0	340	} else {
sl@0	341	/*
sl@0	342	* This is an unquoted word. Call ParseTokens and let it do
sl@0	343	* all of the work.
sl@0	344	*/
sl@0	345
sl@0	346	if (ParseTokens(src, numBytes, TYPE_SPACE\|terminators,
sl@0	347	parsePtr) != TCL_OK) {
sl@0	348	goto error;
sl@0	349	}
sl@0	350	src = parsePtr->term; numBytes = parsePtr->end - src;
sl@0	351	}
sl@0	352
sl@0	353	/*
sl@0	354	* Finish filling in the token for the word and check for the
sl@0	355	* special case of a word consisting of a single range of
sl@0	356	* literal text.
sl@0	357	*/
sl@0	358
sl@0	359	tokenPtr = &parsePtr->tokenPtr[wordIndex];
sl@0	360	tokenPtr->size = src - tokenPtr->start;
sl@0	361	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
sl@0	362	if ((tokenPtr->numComponents == 1)
sl@0	363	&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
sl@0	364	tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
sl@0	365	}
sl@0	366
sl@0	367	/*
sl@0	368	* Do two additional checks: (a) make sure we're really at the
sl@0	369	* end of a word (there might have been garbage left after a
sl@0	370	* quoted or braced word), and (b) check for the end of the
sl@0	371	* command.
sl@0	372	*/
sl@0	373
sl@0	374	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
sl@0	375	if (scanned) {
sl@0	376	src += scanned; numBytes -= scanned;
sl@0	377	continue;
sl@0	378	}
sl@0	379
sl@0	380	if (numBytes == 0) {
sl@0	381	parsePtr->term = src;
sl@0	382	break;
sl@0	383	}
sl@0	384	if ((type & terminators) != 0) {
sl@0	385	parsePtr->term = src;
sl@0	386	src++;
sl@0	387	break;
sl@0	388	}
sl@0	389	if (src[-1] == '"') {
sl@0	390	if (interp != NULL) {
sl@0	391	Tcl_SetResult(interp, "extra characters after close-quote",
sl@0	392	TCL_STATIC);
sl@0	393	}
sl@0	394	parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
sl@0	395	} else {
sl@0	396	if (interp != NULL) {
sl@0	397	Tcl_SetResult(interp, "extra characters after close-brace",
sl@0	398	TCL_STATIC);
sl@0	399	}
sl@0	400	parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
sl@0	401	}
sl@0	402	parsePtr->term = src;
sl@0	403	goto error;
sl@0	404	}
sl@0	405
sl@0	406	parsePtr->commandSize = src - parsePtr->commandStart;
sl@0	407	return TCL_OK;
sl@0	408
sl@0	409	error:
sl@0	410	Tcl_FreeParse(parsePtr);
sl@0	411	if (parsePtr->commandStart == NULL) {
sl@0	412	parsePtr->commandStart = string;
sl@0	413	}
sl@0	414	parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
sl@0	415	return TCL_ERROR;
sl@0	416	}
sl@0	417
sl@0	418	/*
sl@0	419	*----------------------------------------------------------------------
sl@0	420	*
sl@0	421	* TclParseWhiteSpace --
sl@0	422	*
sl@0	423	* Scans up to numBytes bytes starting at src, consuming white
sl@0	424	* space as defined by Tcl's parsing rules.
sl@0	425	*
sl@0	426	* Results:
sl@0	427	* Returns the number of bytes recognized as white space. Records
sl@0	428	* at parsePtr, information about the parse. Records at typePtr
sl@0	429	* the character type of the non-whitespace character that terminated
sl@0	430	* the scan.
sl@0	431	*
sl@0	432	* Side effects:
sl@0	433	* None.
sl@0	434	*
sl@0	435	*----------------------------------------------------------------------
sl@0	436	*/
sl@0	437	int
sl@0	438	TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
sl@0	439	CONST char src; / First character to parse. */
sl@0	440	register int numBytes; /* Max number of bytes to scan. */
sl@0	441	Tcl_Parse parsePtr; / Information about parse in progress.
sl@0	442	* Updated if parsing indicates
sl@0	443	* an incomplete command. */
sl@0	444	char typePtr; / Points to location to store character
sl@0	445	* type of character that ends run
sl@0	446	* of whitespace */
sl@0	447	{
sl@0	448	register char type = TYPE_NORMAL;
sl@0	449	register CONST char *p = src;
sl@0	450
sl@0	451	while (1) {
sl@0	452	while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
sl@0	453	numBytes--; p++;
sl@0	454	}
sl@0	455	if (numBytes && (type & TYPE_SUBS)) {
sl@0	456	if (*p != '\\') {
sl@0	457	break;
sl@0	458	}
sl@0	459	if (--numBytes == 0) {
sl@0	460	break;
sl@0	461	}
sl@0	462	if (p[1] != '\n') {
sl@0	463	break;
sl@0	464	}
sl@0	465	p+=2;
sl@0	466	if (--numBytes == 0) {
sl@0	467	parsePtr->incomplete = 1;
sl@0	468	break;
sl@0	469	}
sl@0	470	continue;
sl@0	471	}
sl@0	472	break;
sl@0	473	}
sl@0	474	*typePtr = type;
sl@0	475	return (p - src);
sl@0	476	}
sl@0	477
sl@0	478	/*
sl@0	479	*----------------------------------------------------------------------
sl@0	480	*
sl@0	481	* TclParseHex --
sl@0	482	*
sl@0	483	* Scans a hexadecimal number as a Tcl_UniChar value.
sl@0	484	* (e.g., for parsing \x and \u escape sequences).
sl@0	485	* At most numBytes bytes are scanned.
sl@0	486	*
sl@0	487	* Results:
sl@0	488	* The numeric value is stored in *resultPtr.
sl@0	489	* Returns the number of bytes consumed.
sl@0	490	*
sl@0	491	* Notes:
sl@0	492	* Relies on the following properties of the ASCII
sl@0	493	* character set, with which UTF-8 is compatible:
sl@0	494	*
sl@0	495	* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z'
sl@0	496	* occupy consecutive code points, and '0' < 'A' < 'a'.
sl@0	497	*
sl@0	498	*----------------------------------------------------------------------
sl@0	499	*/
sl@0	500	int
sl@0	501	TclParseHex(src, numBytes, resultPtr)
sl@0	502	CONST char src; / First character to parse. */
sl@0	503	int numBytes; /* Max number of byes to scan */
sl@0	504	Tcl_UniChar resultPtr; / Points to storage provided by
sl@0	505	* caller where the Tcl_UniChar
sl@0	506	* resulting from the conversion is
sl@0	507	* to be written. */
sl@0	508	{
sl@0	509	Tcl_UniChar result = 0;
sl@0	510	register CONST char *p = src;
sl@0	511
sl@0	512	while (numBytes--) {
sl@0	513	unsigned char digit = UCHAR(*p);
sl@0	514
sl@0	515	if (!isxdigit(digit))
sl@0	516	break;
sl@0	517
sl@0	518	++p;
sl@0	519	result <<= 4;
sl@0	520
sl@0	521	if (digit >= 'a') {
sl@0	522	result \|= (10 + digit - 'a');
sl@0	523	} else if (digit >= 'A') {
sl@0	524	result \|= (10 + digit - 'A');
sl@0	525	} else {
sl@0	526	result \|= (digit - '0');
sl@0	527	}
sl@0	528	}
sl@0	529
sl@0	530	*resultPtr = result;
sl@0	531	return (p - src);
sl@0	532	}
sl@0	533
sl@0	534	/*
sl@0	535	*----------------------------------------------------------------------
sl@0	536	*
sl@0	537	* TclParseBackslash --
sl@0	538	*
sl@0	539	* Scans up to numBytes bytes starting at src, consuming a
sl@0	540	* backslash sequence as defined by Tcl's parsing rules.
sl@0	541	*
sl@0	542	* Results:
sl@0	543	* Records at readPtr the number of bytes making up the backslash
sl@0	544	* sequence. Records at dst the UTF-8 encoded equivalent of
sl@0	545	* that backslash sequence. Returns the number of bytes written
sl@0	546	* to dst, at most TCL_UTF_MAX. Either readPtr or dst may be
sl@0	547	* NULL, if the results are not needed, but the return value is
sl@0	548	* the same either way.
sl@0	549	*
sl@0	550	* Side effects:
sl@0	551	* None.
sl@0	552	*
sl@0	553	*----------------------------------------------------------------------
sl@0	554	*/
sl@0	555	int
sl@0	556	TclParseBackslash(src, numBytes, readPtr, dst)
sl@0	557	CONST char * src; /* Points to the backslash character of a
sl@0	558	* a backslash sequence */
sl@0	559	int numBytes; /* Max number of bytes to scan */
sl@0	560	int readPtr; / NULL, or points to storage where the
sl@0	561	* number of bytes scanned should be written. */
sl@0	562	char dst; / NULL, or points to buffer where the UTF-8
sl@0	563	* encoding of the backslash sequence is to be
sl@0	564	* written. At most TCL_UTF_MAX bytes will be
sl@0	565	* written there. */
sl@0	566	{
sl@0	567	register CONST char *p = src+1;
sl@0	568	Tcl_UniChar result;
sl@0	569	int count;
sl@0	570	char buf[TCL_UTF_MAX];
sl@0	571
sl@0	572	if (numBytes == 0) {
sl@0	573	if (readPtr != NULL) {
sl@0	574	*readPtr = 0;
sl@0	575	}
sl@0	576	return 0;
sl@0	577	}
sl@0	578
sl@0	579	if (dst == NULL) {
sl@0	580	dst = buf;
sl@0	581	}
sl@0	582
sl@0	583	if (numBytes == 1) {
sl@0	584	/* Can only scan the backslash. Return it. */
sl@0	585	result = '\\';
sl@0	586	count = 1;
sl@0	587	goto done;
sl@0	588	}
sl@0	589
sl@0	590	count = 2;
sl@0	591	switch (*p) {
sl@0	592	/*
sl@0	593	* Note: in the conversions below, use absolute values (e.g.,
sl@0	594	* 0xa) rather than symbolic values (e.g. \n) that get converted
sl@0	595	* by the compiler. It's possible that compilers on some
sl@0	596	* platforms will do the symbolic conversions differently, which
sl@0	597	* could result in non-portable Tcl scripts.
sl@0	598	*/
sl@0	599
sl@0	600	case 'a':
sl@0	601	result = 0x7;
sl@0	602	break;
sl@0	603	case 'b':
sl@0	604	result = 0x8;
sl@0	605	break;
sl@0	606	case 'f':
sl@0	607	result = 0xc;
sl@0	608	break;
sl@0	609	case 'n':
sl@0	610	result = 0xa;
sl@0	611	break;
sl@0	612	case 'r':
sl@0	613	result = 0xd;
sl@0	614	break;
sl@0	615	case 't':
sl@0	616	result = 0x9;
sl@0	617	break;
sl@0	618	case 'v':
sl@0	619	result = 0xb;
sl@0	620	break;
sl@0	621	case 'x':
sl@0	622	count += TclParseHex(p+1, numBytes-1, &result);
sl@0	623	if (count == 2) {
sl@0	624	/* No hexadigits -> This is just "x". */
sl@0	625	result = 'x';
sl@0	626	} else {
sl@0	627	/* Keep only the last byte (2 hex digits) */
sl@0	628	result = (unsigned char) result;
sl@0	629	}
sl@0	630	break;
sl@0	631	case 'u':
sl@0	632	count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
sl@0	633	if (count == 2) {
sl@0	634	/* No hexadigits -> This is just "u". */
sl@0	635	result = 'u';
sl@0	636	}
sl@0	637	break;
sl@0	638	case '\n':
sl@0	639	count--;
sl@0	640	do {
sl@0	641	p++; count++;
sl@0	642	} while ((count < numBytes) && ((p == ' ') \|\| (p == '\t')));
sl@0	643	result = ' ';
sl@0	644	break;
sl@0	645	case 0:
sl@0	646	result = '\\';
sl@0	647	count = 1;
sl@0	648	break;
sl@0	649	default:
sl@0	650	/*
sl@0	651	* Check for an octal number \oo?o?
sl@0	652	*/
sl@0	653	if (isdigit(UCHAR(p)) && (UCHAR(p) < '8')) { /* INTL: digit */
sl@0	654	result = (unsigned char)(*p - '0');
sl@0	655	p++;
sl@0	656	if ((numBytes == 2) \|\| !isdigit(UCHAR(p)) / INTL: digit */
sl@0	657	\|\| (UCHAR(*p) >= '8')) {
sl@0	658	break;
sl@0	659	}
sl@0	660	count = 3;
sl@0	661	result = (unsigned char)((result << 3) + (*p - '0'));
sl@0	662	p++;
sl@0	663	if ((numBytes == 3) \|\| !isdigit(UCHAR(p)) / INTL: digit */
sl@0	664	\|\| (UCHAR(*p) >= '8')) {
sl@0	665	break;
sl@0	666	}
sl@0	667	count = 4;
sl@0	668	result = (unsigned char)((result << 3) + (*p - '0'));
sl@0	669	break;
sl@0	670	}
sl@0	671	/*
sl@0	672	* We have to convert here in case the user has put a
sl@0	673	* backslash in front of a multi-byte utf-8 character.
sl@0	674	* While this means nothing special, we shouldn't break up
sl@0	675	* a correct utf-8 character. [Bug #217987] test subst-3.2
sl@0	676	*/
sl@0	677	if (Tcl_UtfCharComplete(p, numBytes - 1)) {
sl@0	678	count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
sl@0	679	} else {
sl@0	680	char utfBytes[TCL_UTF_MAX];
sl@0	681	memcpy(utfBytes, p, (size_t) (numBytes - 1));
sl@0	682	utfBytes[numBytes - 1] = '\0';
sl@0	683	count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
sl@0	684	}
sl@0	685	break;
sl@0	686	}
sl@0	687
sl@0	688	done:
sl@0	689	if (readPtr != NULL) {
sl@0	690	*readPtr = count;
sl@0	691	}
sl@0	692	return Tcl_UniCharToUtf((int) result, dst);
sl@0	693	}
sl@0	694
sl@0	695	/*
sl@0	696	*----------------------------------------------------------------------
sl@0	697	*
sl@0	698	* ParseComment --
sl@0	699	*
sl@0	700	* Scans up to numBytes bytes starting at src, consuming a
sl@0	701	* Tcl comment as defined by Tcl's parsing rules.
sl@0	702	*
sl@0	703	* Results:
sl@0	704	* Records in parsePtr information about the parse. Returns the
sl@0	705	* number of bytes consumed.
sl@0	706	*
sl@0	707	* Side effects:
sl@0	708	* None.
sl@0	709	*
sl@0	710	*----------------------------------------------------------------------
sl@0	711	*/
sl@0	712	static int
sl@0	713	ParseComment(src, numBytes, parsePtr)
sl@0	714	CONST char src; / First character to parse. */
sl@0	715	register int numBytes; /* Max number of bytes to scan. */
sl@0	716	Tcl_Parse parsePtr; / Information about parse in progress.
sl@0	717	* Updated if parsing indicates
sl@0	718	* an incomplete command. */
sl@0	719	{
sl@0	720	register CONST char *p = src;
sl@0	721	while (numBytes) {
sl@0	722	char type;
sl@0	723	int scanned;
sl@0	724	do {
sl@0	725	scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
sl@0	726	p += scanned; numBytes -= scanned;
sl@0	727	} while (numBytes && (*p == '\n') && (p++,numBytes--));
sl@0	728	if ((numBytes == 0) \|\| (*p != '#')) {
sl@0	729	break;
sl@0	730	}
sl@0	731	if (parsePtr->commentStart == NULL) {
sl@0	732	parsePtr->commentStart = p;
sl@0	733	}
sl@0	734	while (numBytes) {
sl@0	735	if (*p == '\\') {
sl@0	736	scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
sl@0	737	if (scanned) {
sl@0	738	p += scanned; numBytes -= scanned;
sl@0	739	} else {
sl@0	740	/*
sl@0	741	* General backslash substitution in comments isn't
sl@0	742	* part of the formal spec, but test parse-15.47
sl@0	743	* and history indicate that it has been the de facto
sl@0	744	* rule. Don't change it now.
sl@0	745	*/
sl@0	746	TclParseBackslash(p, numBytes, &scanned, NULL);
sl@0	747	p += scanned; numBytes -= scanned;
sl@0	748	}
sl@0	749	} else {
sl@0	750	p++; numBytes--;
sl@0	751	if (p[-1] == '\n') {
sl@0	752	break;
sl@0	753	}
sl@0	754	}
sl@0	755	}
sl@0	756	parsePtr->commentSize = p - parsePtr->commentStart;
sl@0	757	}
sl@0	758	return (p - src);
sl@0	759	}
sl@0	760
sl@0	761	/*
sl@0	762	*----------------------------------------------------------------------
sl@0	763	*
sl@0	764	* ParseTokens --
sl@0	765	*
sl@0	766	* This procedure forms the heart of the Tcl parser. It parses one
sl@0	767	* or more tokens from a string, up to a termination point
sl@0	768	* specified by the caller. This procedure is used to parse
sl@0	769	* unquoted command words (those not in quotes or braces), words in
sl@0	770	* quotes, and array indices for variables. No more than numBytes
sl@0	771	* bytes will be scanned.
sl@0	772	*
sl@0	773	* Results:
sl@0	774	* Tokens are added to parsePtr and parsePtr->term is filled in
sl@0	775	* with the address of the character that terminated the parse (the
sl@0	776	* first one whose CHAR_TYPE matched mask or the character at
sl@0	777	* parsePtr->end). The return value is TCL_OK if the parse
sl@0	778	* completed successfully and TCL_ERROR otherwise. If a parse
sl@0	779	* error occurs and parsePtr->interp isn't NULL, then an error
sl@0	780	* message is left in the interpreter's result.
sl@0	781	*
sl@0	782	* Side effects:
sl@0	783	* None.
sl@0	784	*
sl@0	785	*----------------------------------------------------------------------
sl@0	786	*/
sl@0	787
sl@0	788	static int
sl@0	789	ParseTokens(src, numBytes, mask, parsePtr)
sl@0	790	register CONST char src; / First character to parse. */
sl@0	791	register int numBytes; /* Max number of bytes to scan. */
sl@0	792	int mask; /* Specifies when to stop parsing. The
sl@0	793	* parse stops at the first unquoted
sl@0	794	* character whose CHAR_TYPE contains
sl@0	795	* any of the bits in mask. */
sl@0	796	Tcl_Parse parsePtr; / Information about parse in progress.
sl@0	797	* Updated with additional tokens and
sl@0	798	* termination information. */
sl@0	799	{
sl@0	800	char type;
sl@0	801	int originalTokens, varToken;
sl@0	802	Tcl_Token *tokenPtr;
sl@0	803	Tcl_Parse nested;
sl@0	804
sl@0	805	/*
sl@0	806	* Each iteration through the following loop adds one token of
sl@0	807	* type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
sl@0	808	* TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens,
sl@0	809	* additional tokens are added for the parsed variable name.
sl@0	810	*/
sl@0	811
sl@0	812	originalTokens = parsePtr->numTokens;
sl@0	813	while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
sl@0	814	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
sl@0	815	TclExpandTokenArray(parsePtr);
sl@0	816	}
sl@0	817	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
sl@0	818	tokenPtr->start = src;
sl@0	819	tokenPtr->numComponents = 0;
sl@0	820
sl@0	821	if ((type & TYPE_SUBS) == 0) {
sl@0	822	/*
sl@0	823	* This is a simple range of characters. Scan to find the end
sl@0	824	* of the range.
sl@0	825	*/
sl@0	826
sl@0	827	while ((++src, --numBytes)
sl@0	828	&& !(CHAR_TYPE(*src) & (mask \| TYPE_SUBS))) {
sl@0	829	/* empty loop */
sl@0	830	}
sl@0	831	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	832	tokenPtr->size = src - tokenPtr->start;
sl@0	833	parsePtr->numTokens++;
sl@0	834	} else if (*src == '$') {
sl@0	835	/*
sl@0	836	* This is a variable reference. Call Tcl_ParseVarName to do
sl@0	837	* all the dirty work of parsing the name.
sl@0	838	*/
sl@0	839
sl@0	840	varToken = parsePtr->numTokens;
sl@0	841	if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
sl@0	842	parsePtr, 1) != TCL_OK) {
sl@0	843	return TCL_ERROR;
sl@0	844	}
sl@0	845	src += parsePtr->tokenPtr[varToken].size;
sl@0	846	numBytes -= parsePtr->tokenPtr[varToken].size;
sl@0	847	} else if (*src == '[') {
sl@0	848	/*
sl@0	849	* Command substitution. Call Tcl_ParseCommand recursively
sl@0	850	* (and repeatedly) to parse the nested command(s), then
sl@0	851	* throw away the parse information.
sl@0	852	*/
sl@0	853
sl@0	854	src++; numBytes--;
sl@0	855	while (1) {
sl@0	856	if (Tcl_ParseCommand(parsePtr->interp, src,
sl@0	857	numBytes, 1, &nested) != TCL_OK) {
sl@0	858	parsePtr->errorType = nested.errorType;
sl@0	859	parsePtr->term = nested.term;
sl@0	860	parsePtr->incomplete = nested.incomplete;
sl@0	861	return TCL_ERROR;
sl@0	862	}
sl@0	863	src = nested.commandStart + nested.commandSize;
sl@0	864	numBytes = parsePtr->end - src;
sl@0	865
sl@0	866	/*
sl@0	867	* This is equivalent to Tcl_FreeParse(&nested), but
sl@0	868	* presumably inlined here for sake of runtime optimization
sl@0	869	*/
sl@0	870
sl@0	871	if (nested.tokenPtr != nested.staticTokens) {
sl@0	872	ckfree((char *) nested.tokenPtr);
sl@0	873	}
sl@0	874
sl@0	875	/*
sl@0	876	* Check for the closing ']' that ends the command
sl@0	877	* substitution. It must have been the last character of
sl@0	878	* the parsed command.
sl@0	879	*/
sl@0	880
sl@0	881	if ((nested.term < parsePtr->end) && (*nested.term == ']')
sl@0	882	&& !nested.incomplete) {
sl@0	883	break;
sl@0	884	}
sl@0	885	if (numBytes == 0) {
sl@0	886	if (parsePtr->interp != NULL) {
sl@0	887	Tcl_SetResult(parsePtr->interp,
sl@0	888	"missing close-bracket", TCL_STATIC);
sl@0	889	}
sl@0	890	parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
sl@0	891	parsePtr->term = tokenPtr->start;
sl@0	892	parsePtr->incomplete = 1;
sl@0	893	return TCL_ERROR;
sl@0	894	}
sl@0	895	}
sl@0	896	tokenPtr->type = TCL_TOKEN_COMMAND;
sl@0	897	tokenPtr->size = src - tokenPtr->start;
sl@0	898	parsePtr->numTokens++;
sl@0	899	} else if (*src == '\\') {
sl@0	900	/*
sl@0	901	* Backslash substitution.
sl@0	902	*/
sl@0	903	TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
sl@0	904
sl@0	905	if (tokenPtr->size == 1) {
sl@0	906	/* Just a backslash, due to end of string */
sl@0	907	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	908	parsePtr->numTokens++;
sl@0	909	src++; numBytes--;
sl@0	910	continue;
sl@0	911	}
sl@0	912
sl@0	913	if (src[1] == '\n') {
sl@0	914	if (numBytes == 2) {
sl@0	915	parsePtr->incomplete = 1;
sl@0	916	}
sl@0	917
sl@0	918	/*
sl@0	919	* Note: backslash-newline is special in that it is
sl@0	920	* treated the same as a space character would be. This
sl@0	921	* means that it could terminate the token.
sl@0	922	*/
sl@0	923
sl@0	924	if (mask & TYPE_SPACE) {
sl@0	925	if (parsePtr->numTokens == originalTokens) {
sl@0	926	goto finishToken;
sl@0	927	}
sl@0	928	break;
sl@0	929	}
sl@0	930	}
sl@0	931
sl@0	932	tokenPtr->type = TCL_TOKEN_BS;
sl@0	933	parsePtr->numTokens++;
sl@0	934	src += tokenPtr->size;
sl@0	935	numBytes -= tokenPtr->size;
sl@0	936	} else if (*src == 0) {
sl@0	937	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	938	tokenPtr->size = 1;
sl@0	939	parsePtr->numTokens++;
sl@0	940	src++; numBytes--;
sl@0	941	} else {
sl@0	942	panic("ParseTokens encountered unknown character");
sl@0	943	}
sl@0	944	}
sl@0	945	if (parsePtr->numTokens == originalTokens) {
sl@0	946	/*
sl@0	947	* There was nothing in this range of text. Add an empty token
sl@0	948	* for the empty range, so that there is always at least one
sl@0	949	* token added.
sl@0	950	*/
sl@0	951	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
sl@0	952	TclExpandTokenArray(parsePtr);
sl@0	953	}
sl@0	954	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
sl@0	955	tokenPtr->start = src;
sl@0	956	tokenPtr->numComponents = 0;
sl@0	957
sl@0	958	finishToken:
sl@0	959	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	960	tokenPtr->size = 0;
sl@0	961	parsePtr->numTokens++;
sl@0	962	}
sl@0	963	parsePtr->term = src;
sl@0	964	return TCL_OK;
sl@0	965	}
sl@0	966
sl@0	967	/*
sl@0	968	*----------------------------------------------------------------------
sl@0	969	*
sl@0	970	* Tcl_FreeParse --
sl@0	971	*
sl@0	972	* This procedure is invoked to free any dynamic storage that may
sl@0	973	* have been allocated by a previous call to Tcl_ParseCommand.
sl@0	974	*
sl@0	975	* Results:
sl@0	976	* None.
sl@0	977	*
sl@0	978	* Side effects:
sl@0	979	* If there is any dynamically allocated memory in *parsePtr,
sl@0	980	* it is freed.
sl@0	981	*
sl@0	982	*----------------------------------------------------------------------
sl@0	983	*/
sl@0	984
sl@0	985	EXPORT_C void
sl@0	986	Tcl_FreeParse(parsePtr)
sl@0	987	Tcl_Parse parsePtr; / Structure that was filled in by a
sl@0	988	* previous call to Tcl_ParseCommand. */
sl@0	989	{
sl@0	990	if (parsePtr->tokenPtr != parsePtr->staticTokens) {
sl@0	991	ckfree((char *) parsePtr->tokenPtr);
sl@0	992	parsePtr->tokenPtr = parsePtr->staticTokens;
sl@0	993	}
sl@0	994	}
sl@0	995
sl@0	996	/*
sl@0	997	*----------------------------------------------------------------------
sl@0	998	*
sl@0	999	* TclExpandTokenArray --
sl@0	1000	*
sl@0	1001	* This procedure is invoked when the current space for tokens in
sl@0	1002	* a Tcl_Parse structure fills up; it allocates memory to grow the
sl@0	1003	* token array
sl@0	1004	*
sl@0	1005	* Results:
sl@0	1006	* None.
sl@0	1007	*
sl@0	1008	* Side effects:
sl@0	1009	* Memory is allocated for a new larger token array; the memory
sl@0	1010	* for the old array is freed, if it had been dynamically allocated.
sl@0	1011	*
sl@0	1012	*----------------------------------------------------------------------
sl@0	1013	*/
sl@0	1014
sl@0	1015	void
sl@0	1016	TclExpandTokenArray(parsePtr)
sl@0	1017	Tcl_Parse parsePtr; / Parse structure whose token space
sl@0	1018	* has overflowed. */
sl@0	1019	{
sl@0	1020	int newCount;
sl@0	1021	Tcl_Token *newPtr;
sl@0	1022
sl@0	1023	newCount = parsePtr->tokensAvailable*2;
sl@0	1024	newPtr = (Tcl_Token ) ckalloc((unsigned) (newCount sizeof(Tcl_Token)));
sl@0	1025	memcpy((VOID ) newPtr, (VOID ) parsePtr->tokenPtr,
sl@0	1026	(size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
sl@0	1027	if (parsePtr->tokenPtr != parsePtr->staticTokens) {
sl@0	1028	ckfree((char *) parsePtr->tokenPtr);
sl@0	1029	}
sl@0	1030	parsePtr->tokenPtr = newPtr;
sl@0	1031	parsePtr->tokensAvailable = newCount;
sl@0	1032	}
sl@0	1033
sl@0	1034	/*
sl@0	1035	*----------------------------------------------------------------------
sl@0	1036	*
sl@0	1037	* Tcl_ParseVarName --
sl@0	1038	*
sl@0	1039	* Given a string starting with a $ sign, parse off a variable
sl@0	1040	* name and return information about the parse. No more than
sl@0	1041	* numBytes bytes will be scanned.
sl@0	1042	*
sl@0	1043	* Results:
sl@0	1044	* The return value is TCL_OK if the command was parsed
sl@0	1045	* successfully and TCL_ERROR otherwise. If an error occurs and
sl@0	1046	* interp isn't NULL then an error message is left in its result.
sl@0	1047	* On a successful return, tokenPtr and numTokens fields of
sl@0	1048	* parsePtr are filled in with information about the variable name
sl@0	1049	* that was parsed. The "size" field of the first new token gives
sl@0	1050	* the total number of bytes in the variable name. Other fields in
sl@0	1051	* parsePtr are undefined.
sl@0	1052	*
sl@0	1053	* Side effects:
sl@0	1054	* If there is insufficient space in parsePtr to hold all the
sl@0	1055	* information about the command, then additional space is
sl@0	1056	* malloc-ed. If the procedure returns TCL_OK then the caller must
sl@0	1057	* eventually invoke Tcl_FreeParse to release any additional space
sl@0	1058	* that was allocated.
sl@0	1059	*
sl@0	1060	*----------------------------------------------------------------------
sl@0	1061	*/
sl@0	1062
sl@0	1063	EXPORT_C int
sl@0	1064	Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
sl@0	1065	Tcl_Interp interp; / Interpreter to use for error reporting;
sl@0	1066	* if NULL, then no error message is
sl@0	1067	* provided. */
sl@0	1068	CONST char string; / String containing variable name. First
sl@0	1069	* character must be "$". */
sl@0	1070	register int numBytes; /* Total number of bytes in string. If < 0,
sl@0	1071	* the string consists of all bytes up to the
sl@0	1072	* first null character. */
sl@0	1073	Tcl_Parse parsePtr; / Structure to fill in with information
sl@0	1074	* about the variable name. */
sl@0	1075	int append; /* Non-zero means append tokens to existing
sl@0	1076	* information in parsePtr; zero means ignore
sl@0	1077	* existing tokens in parsePtr and reinitialize
sl@0	1078	* it. */
sl@0	1079	{
sl@0	1080	Tcl_Token *tokenPtr;
sl@0	1081	register CONST char *src;
sl@0	1082	unsigned char c;
sl@0	1083	int varIndex, offset;
sl@0	1084	Tcl_UniChar ch;
sl@0	1085	unsigned array;
sl@0	1086
sl@0	1087	if ((numBytes == 0) \|\| (string == NULL)) {
sl@0	1088	return TCL_ERROR;
sl@0	1089	}
sl@0	1090	if (numBytes < 0) {
sl@0	1091	numBytes = strlen(string);
sl@0	1092	}
sl@0	1093
sl@0	1094	if (!append) {
sl@0	1095	parsePtr->numWords = 0;
sl@0	1096	parsePtr->tokenPtr = parsePtr->staticTokens;
sl@0	1097	parsePtr->numTokens = 0;
sl@0	1098	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
sl@0	1099	parsePtr->string = string;
sl@0	1100	parsePtr->end = (string + numBytes);
sl@0	1101	parsePtr->interp = interp;
sl@0	1102	parsePtr->errorType = TCL_PARSE_SUCCESS;
sl@0	1103	parsePtr->incomplete = 0;
sl@0	1104	}
sl@0	1105
sl@0	1106	/*
sl@0	1107	* Generate one token for the variable, an additional token for the
sl@0	1108	* name, plus any number of additional tokens for the index, if
sl@0	1109	* there is one.
sl@0	1110	*/
sl@0	1111
sl@0	1112	src = string;
sl@0	1113	if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
sl@0	1114	TclExpandTokenArray(parsePtr);
sl@0	1115	}
sl@0	1116	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
sl@0	1117	tokenPtr->type = TCL_TOKEN_VARIABLE;
sl@0	1118	tokenPtr->start = src;
sl@0	1119	varIndex = parsePtr->numTokens;
sl@0	1120	parsePtr->numTokens++;
sl@0	1121	tokenPtr++;
sl@0	1122	src++; numBytes--;
sl@0	1123	if (numBytes == 0) {
sl@0	1124	goto justADollarSign;
sl@0	1125	}
sl@0	1126	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1127	tokenPtr->start = src;
sl@0	1128	tokenPtr->numComponents = 0;
sl@0	1129
sl@0	1130	/*
sl@0	1131	* The name of the variable can have three forms:
sl@0	1132	* 1. The $ sign is followed by an open curly brace. Then
sl@0	1133	* the variable name is everything up to the next close
sl@0	1134	* curly brace, and the variable is a scalar variable.
sl@0	1135	* 2. The $ sign is not followed by an open curly brace. Then
sl@0	1136	* the variable name is everything up to the next
sl@0	1137	* character that isn't a letter, digit, or underscore.
sl@0	1138	* :: sequences are also considered part of the variable
sl@0	1139	* name, in order to support namespaces. If the following
sl@0	1140	* character is an open parenthesis, then the information
sl@0	1141	* between parentheses is the array element name.
sl@0	1142	* 3. The $ sign is followed by something that isn't a letter,
sl@0	1143	* digit, or underscore: in this case, there is no variable
sl@0	1144	* name and the token is just "$".
sl@0	1145	*/
sl@0	1146
sl@0	1147	if (*src == '{') {
sl@0	1148	src++; numBytes--;
sl@0	1149	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1150	tokenPtr->start = src;
sl@0	1151	tokenPtr->numComponents = 0;
sl@0	1152
sl@0	1153	while (numBytes && (*src != '}')) {
sl@0	1154	numBytes--; src++;
sl@0	1155	}
sl@0	1156	if (numBytes == 0) {
sl@0	1157	if (interp != NULL) {
sl@0	1158	Tcl_SetResult(interp, "missing close-brace for variable name",
sl@0	1159	TCL_STATIC);
sl@0	1160	}
sl@0	1161	parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
sl@0	1162	parsePtr->term = tokenPtr->start-1;
sl@0	1163	parsePtr->incomplete = 1;
sl@0	1164	goto error;
sl@0	1165	}
sl@0	1166	tokenPtr->size = src - tokenPtr->start;
sl@0	1167	tokenPtr[-1].size = src - tokenPtr[-1].start;
sl@0	1168	parsePtr->numTokens++;
sl@0	1169	src++;
sl@0	1170	} else {
sl@0	1171	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1172	tokenPtr->start = src;
sl@0	1173	tokenPtr->numComponents = 0;
sl@0	1174	while (numBytes) {
sl@0	1175	if (Tcl_UtfCharComplete(src, numBytes)) {
sl@0	1176	offset = Tcl_UtfToUniChar(src, &ch);
sl@0	1177	} else {
sl@0	1178	char utfBytes[TCL_UTF_MAX];
sl@0	1179	memcpy(utfBytes, src, (size_t) numBytes);
sl@0	1180	utfBytes[numBytes] = '\0';
sl@0	1181	offset = Tcl_UtfToUniChar(utfBytes, &ch);
sl@0	1182	}
sl@0	1183	c = UCHAR(ch);
sl@0	1184	if (isalnum(c) \|\| (c == '_')) { /* INTL: ISO only, UCHAR. */
sl@0	1185	src += offset; numBytes -= offset;
sl@0	1186	continue;
sl@0	1187	}
sl@0	1188	if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
sl@0	1189	src += 2; numBytes -= 2;
sl@0	1190	while (numBytes && (*src == ':')) {
sl@0	1191	src++; numBytes--;
sl@0	1192	}
sl@0	1193	continue;
sl@0	1194	}
sl@0	1195	break;
sl@0	1196	}
sl@0	1197
sl@0	1198	/*
sl@0	1199	* Support for empty array names here.
sl@0	1200	*/
sl@0	1201	array = (numBytes && (*src == '('));
sl@0	1202	tokenPtr->size = src - tokenPtr->start;
sl@0	1203	if ((tokenPtr->size == 0) && !array) {
sl@0	1204	goto justADollarSign;
sl@0	1205	}
sl@0	1206	parsePtr->numTokens++;
sl@0	1207	if (array) {
sl@0	1208	/*
sl@0	1209	* This is a reference to an array element. Call
sl@0	1210	* ParseTokens recursively to parse the element name,
sl@0	1211	* since it could contain any number of substitutions.
sl@0	1212	*/
sl@0	1213
sl@0	1214	if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
sl@0	1215	!= TCL_OK) {
sl@0	1216	goto error;
sl@0	1217	}
sl@0	1218	if ((parsePtr->term == (src + numBytes))
sl@0	1219	\|\| (*parsePtr->term != ')')) {
sl@0	1220	if (parsePtr->interp != NULL) {
sl@0	1221	Tcl_SetResult(parsePtr->interp, "missing )",
sl@0	1222	TCL_STATIC);
sl@0	1223	}
sl@0	1224	parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
sl@0	1225	parsePtr->term = src;
sl@0	1226	parsePtr->incomplete = 1;
sl@0	1227	goto error;
sl@0	1228	}
sl@0	1229	src = parsePtr->term + 1;
sl@0	1230	}
sl@0	1231	}
sl@0	1232	tokenPtr = &parsePtr->tokenPtr[varIndex];
sl@0	1233	tokenPtr->size = src - tokenPtr->start;
sl@0	1234	tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
sl@0	1235	return TCL_OK;
sl@0	1236
sl@0	1237	/*
sl@0	1238	* The dollar sign isn't followed by a variable name.
sl@0	1239	* replace the TCL_TOKEN_VARIABLE token with a
sl@0	1240	* TCL_TOKEN_TEXT token for the dollar sign.
sl@0	1241	*/
sl@0	1242
sl@0	1243	justADollarSign:
sl@0	1244	tokenPtr = &parsePtr->tokenPtr[varIndex];
sl@0	1245	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1246	tokenPtr->size = 1;
sl@0	1247	tokenPtr->numComponents = 0;
sl@0	1248	return TCL_OK;
sl@0	1249
sl@0	1250	error:
sl@0	1251	Tcl_FreeParse(parsePtr);
sl@0	1252	return TCL_ERROR;
sl@0	1253	}
sl@0	1254
sl@0	1255	/*
sl@0	1256	*----------------------------------------------------------------------
sl@0	1257	*
sl@0	1258	* Tcl_ParseVar --
sl@0	1259	*
sl@0	1260	* Given a string starting with a $ sign, parse off a variable
sl@0	1261	* name and return its value.
sl@0	1262	*
sl@0	1263	* Results:
sl@0	1264	* The return value is the contents of the variable given by
sl@0	1265	* the leading characters of string. If termPtr isn't NULL,
sl@0	1266	* *termPtr gets filled in with the address of the character
sl@0	1267	* just after the last one in the variable specifier. If the
sl@0	1268	* variable doesn't exist, then the return value is NULL and
sl@0	1269	* an error message will be left in interp's result.
sl@0	1270	*
sl@0	1271	* Side effects:
sl@0	1272	* None.
sl@0	1273	*
sl@0	1274	*----------------------------------------------------------------------
sl@0	1275	*/
sl@0	1276
sl@0	1277	EXPORT_C CONST char *
sl@0	1278	Tcl_ParseVar(interp, string, termPtr)
sl@0	1279	Tcl_Interp interp; / Context for looking up variable. */
sl@0	1280	register CONST char string; / String containing variable name.
sl@0	1281	* First character must be "$". */
sl@0	1282	CONST char *termPtr; / If non-NULL, points to word to fill
sl@0	1283	* in with character just after last
sl@0	1284	* one in the variable specifier. */
sl@0	1285
sl@0	1286	{
sl@0	1287	Tcl_Parse parse;
sl@0	1288	register Tcl_Obj *objPtr;
sl@0	1289	int code;
sl@0	1290
sl@0	1291	if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
sl@0	1292	return NULL;
sl@0	1293	}
sl@0	1294
sl@0	1295	if (termPtr != NULL) {
sl@0	1296	*termPtr = string + parse.tokenPtr->size;
sl@0	1297	}
sl@0	1298	if (parse.numTokens == 1) {
sl@0	1299	/*
sl@0	1300	* There isn't a variable name after all: the $ is just a $.
sl@0	1301	*/
sl@0	1302
sl@0	1303	return "$";
sl@0	1304	}
sl@0	1305
sl@0	1306	code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens);
sl@0	1307	if (code != TCL_OK) {
sl@0	1308	return NULL;
sl@0	1309	}
sl@0	1310	objPtr = Tcl_GetObjResult(interp);
sl@0	1311
sl@0	1312	/*
sl@0	1313	* At this point we should have an object containing the value of
sl@0	1314	* a variable. Just return the string from that object.
sl@0	1315	*
sl@0	1316	* This should have returned the object for the user to manage, but
sl@0	1317	* instead we have some weak reference to the string value in the
sl@0	1318	* object, which is why we make sure the object exists after resetting
sl@0	1319	* the result. This isn't ideal, but it's the best we can do with the
sl@0	1320	* current documented interface. -- hobbs
sl@0	1321	*/
sl@0	1322
sl@0	1323	if (!Tcl_IsShared(objPtr)) {
sl@0	1324	Tcl_IncrRefCount(objPtr);
sl@0	1325	}
sl@0	1326	Tcl_ResetResult(interp);
sl@0	1327	return TclGetString(objPtr);
sl@0	1328	}
sl@0	1329
sl@0	1330	/*
sl@0	1331	*----------------------------------------------------------------------
sl@0	1332	*
sl@0	1333	* Tcl_ParseBraces --
sl@0	1334	*
sl@0	1335	* Given a string in braces such as a Tcl command argument or a string
sl@0	1336	* value in a Tcl expression, this procedure parses the string and
sl@0	1337	* returns information about the parse. No more than numBytes bytes
sl@0	1338	* will be scanned.
sl@0	1339	*
sl@0	1340	* Results:
sl@0	1341	* The return value is TCL_OK if the string was parsed successfully and
sl@0	1342	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
sl@0	1343	* an error message is left in its result. On a successful return,
sl@0	1344	* tokenPtr and numTokens fields of parsePtr are filled in with
sl@0	1345	* information about the string that was parsed. Other fields in
sl@0	1346	* parsePtr are undefined. termPtr is set to point to the character
sl@0	1347	* just after the last one in the braced string.
sl@0	1348	*
sl@0	1349	* Side effects:
sl@0	1350	* If there is insufficient space in parsePtr to hold all the
sl@0	1351	* information about the command, then additional space is
sl@0	1352	* malloc-ed. If the procedure returns TCL_OK then the caller must
sl@0	1353	* eventually invoke Tcl_FreeParse to release any additional space
sl@0	1354	* that was allocated.
sl@0	1355	*
sl@0	1356	*----------------------------------------------------------------------
sl@0	1357	*/
sl@0	1358
sl@0	1359	EXPORT_C int
sl@0	1360	Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
sl@0	1361	Tcl_Interp interp; / Interpreter to use for error reporting;
sl@0	1362	* if NULL, then no error message is
sl@0	1363	* provided. */
sl@0	1364	CONST char string; / String containing the string in braces.
sl@0	1365	* The first character must be '{'. */
sl@0	1366	register int numBytes; /* Total number of bytes in string. If < 0,
sl@0	1367	* the string consists of all bytes up to
sl@0	1368	* the first null character. */
sl@0	1369	register Tcl_Parse *parsePtr;
sl@0	1370	/* Structure to fill in with information
sl@0	1371	* about the string. */
sl@0	1372	int append; /* Non-zero means append tokens to existing
sl@0	1373	* information in parsePtr; zero means
sl@0	1374	* ignore existing tokens in parsePtr and
sl@0	1375	* reinitialize it. */
sl@0	1376	CONST char *termPtr; / If non-NULL, points to word in which to
sl@0	1377	* store a pointer to the character just
sl@0	1378	* after the terminating '}' if the parse
sl@0	1379	* was successful. */
sl@0	1380
sl@0	1381	{
sl@0	1382	Tcl_Token *tokenPtr;
sl@0	1383	register CONST char *src;
sl@0	1384	int startIndex, level, length;
sl@0	1385
sl@0	1386	if ((numBytes == 0) \|\| (string == NULL)) {
sl@0	1387	return TCL_ERROR;
sl@0	1388	}
sl@0	1389	if (numBytes < 0) {
sl@0	1390	numBytes = strlen(string);
sl@0	1391	}
sl@0	1392
sl@0	1393	if (!append) {
sl@0	1394	parsePtr->numWords = 0;
sl@0	1395	parsePtr->tokenPtr = parsePtr->staticTokens;
sl@0	1396	parsePtr->numTokens = 0;
sl@0	1397	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
sl@0	1398	parsePtr->string = string;
sl@0	1399	parsePtr->end = (string + numBytes);
sl@0	1400	parsePtr->interp = interp;
sl@0	1401	parsePtr->errorType = TCL_PARSE_SUCCESS;
sl@0	1402	}
sl@0	1403
sl@0	1404	src = string;
sl@0	1405	startIndex = parsePtr->numTokens;
sl@0	1406
sl@0	1407	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
sl@0	1408	TclExpandTokenArray(parsePtr);
sl@0	1409	}
sl@0	1410	tokenPtr = &parsePtr->tokenPtr[startIndex];
sl@0	1411	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1412	tokenPtr->start = src+1;
sl@0	1413	tokenPtr->numComponents = 0;
sl@0	1414	level = 1;
sl@0	1415	while (1) {
sl@0	1416	while (++src, --numBytes) {
sl@0	1417	if (CHAR_TYPE(*src) != TYPE_NORMAL) {
sl@0	1418	break;
sl@0	1419	}
sl@0	1420	}
sl@0	1421	if (numBytes == 0) {
sl@0	1422	register int openBrace = 0;
sl@0	1423
sl@0	1424	parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
sl@0	1425	parsePtr->term = string;
sl@0	1426	parsePtr->incomplete = 1;
sl@0	1427	if (interp == NULL) {
sl@0	1428	/*
sl@0	1429	* Skip straight to the exit code since we have no
sl@0	1430	* interpreter to put error message in.
sl@0	1431	*/
sl@0	1432	goto error;
sl@0	1433	}
sl@0	1434
sl@0	1435	Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
sl@0	1436
sl@0	1437	/*
sl@0	1438	* Guess if the problem is due to comments by searching
sl@0	1439	* the source string for a possible open brace within the
sl@0	1440	* context of a comment. Since we aren't performing a
sl@0	1441	* full Tcl parse, just look for an open brace preceded
sl@0	1442	* by a '<whitespace>#' on the same line.
sl@0	1443	*/
sl@0	1444
sl@0	1445	for (; src > string; src--) {
sl@0	1446	switch (*src) {
sl@0	1447	case '{':
sl@0	1448	openBrace = 1;
sl@0	1449	break;
sl@0	1450	case '\n':
sl@0	1451	openBrace = 0;
sl@0	1452	break;
sl@0	1453	case '#' :
sl@0	1454	if (openBrace && (isspace(UCHAR(src[-1])))) {
sl@0	1455	Tcl_AppendResult(interp,
sl@0	1456	": possible unbalanced brace in comment",
sl@0	1457	(char *) NULL);
sl@0	1458	goto error;
sl@0	1459	}
sl@0	1460	break;
sl@0	1461	}
sl@0	1462	}
sl@0	1463
sl@0	1464	error:
sl@0	1465	Tcl_FreeParse(parsePtr);
sl@0	1466	return TCL_ERROR;
sl@0	1467	}
sl@0	1468	switch (*src) {
sl@0	1469	case '{':
sl@0	1470	level++;
sl@0	1471	break;
sl@0	1472	case '}':
sl@0	1473	if (--level == 0) {
sl@0	1474
sl@0	1475	/*
sl@0	1476	* Decide if we need to finish emitting a
sl@0	1477	* partially-finished token. There are 3 cases:
sl@0	1478	* {abc \newline xyz} or {xyz}
sl@0	1479	* - finish emitting "xyz" token
sl@0	1480	* {abc \newline}
sl@0	1481	* - don't emit token after \newline
sl@0	1482	* {} - finish emitting zero-sized token
sl@0	1483	*
sl@0	1484	* The last case ensures that there is a token
sl@0	1485	* (even if empty) that describes the braced string.
sl@0	1486	*/
sl@0	1487
sl@0	1488	if ((src != tokenPtr->start)
sl@0	1489	\|\| (parsePtr->numTokens == startIndex)) {
sl@0	1490	tokenPtr->size = (src - tokenPtr->start);
sl@0	1491	parsePtr->numTokens++;
sl@0	1492	}
sl@0	1493	if (termPtr != NULL) {
sl@0	1494	*termPtr = src+1;
sl@0	1495	}
sl@0	1496	return TCL_OK;
sl@0	1497	}
sl@0	1498	break;
sl@0	1499	case '\\':
sl@0	1500	TclParseBackslash(src, numBytes, &length, NULL);
sl@0	1501	if ((length > 1) && (src[1] == '\n')) {
sl@0	1502	/*
sl@0	1503	* A backslash-newline sequence must be collapsed, even
sl@0	1504	* inside braces, so we have to split the word into
sl@0	1505	* multiple tokens so that the backslash-newline can be
sl@0	1506	* represented explicitly.
sl@0	1507	*/
sl@0	1508
sl@0	1509	if (numBytes == 2) {
sl@0	1510	parsePtr->incomplete = 1;
sl@0	1511	}
sl@0	1512	tokenPtr->size = (src - tokenPtr->start);
sl@0	1513	if (tokenPtr->size != 0) {
sl@0	1514	parsePtr->numTokens++;
sl@0	1515	}
sl@0	1516	if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
sl@0	1517	TclExpandTokenArray(parsePtr);
sl@0	1518	}
sl@0	1519	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
sl@0	1520	tokenPtr->type = TCL_TOKEN_BS;
sl@0	1521	tokenPtr->start = src;
sl@0	1522	tokenPtr->size = length;
sl@0	1523	tokenPtr->numComponents = 0;
sl@0	1524	parsePtr->numTokens++;
sl@0	1525
sl@0	1526	src += length - 1;
sl@0	1527	numBytes -= length - 1;
sl@0	1528	tokenPtr++;
sl@0	1529	tokenPtr->type = TCL_TOKEN_TEXT;
sl@0	1530	tokenPtr->start = src + 1;
sl@0	1531	tokenPtr->numComponents = 0;
sl@0	1532	} else {
sl@0	1533	src += length - 1;
sl@0	1534	numBytes -= length - 1;
sl@0	1535	}
sl@0	1536	break;
sl@0	1537	}
sl@0	1538	}
sl@0	1539	}
sl@0	1540
sl@0	1541	/*
sl@0	1542	*----------------------------------------------------------------------
sl@0	1543	*
sl@0	1544	* Tcl_ParseQuotedString --
sl@0	1545	*
sl@0	1546	* Given a double-quoted string such as a quoted Tcl command argument
sl@0	1547	* or a quoted value in a Tcl expression, this procedure parses the
sl@0	1548	* string and returns information about the parse. No more than
sl@0	1549	* numBytes bytes will be scanned.
sl@0	1550	*
sl@0	1551	* Results:
sl@0	1552	* The return value is TCL_OK if the string was parsed successfully and
sl@0	1553	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
sl@0	1554	* an error message is left in its result. On a successful return,
sl@0	1555	* tokenPtr and numTokens fields of parsePtr are filled in with
sl@0	1556	* information about the string that was parsed. Other fields in
sl@0	1557	* parsePtr are undefined. termPtr is set to point to the character
sl@0	1558	* just after the quoted string's terminating close-quote.
sl@0	1559	*
sl@0	1560	* Side effects:
sl@0	1561	* If there is insufficient space in parsePtr to hold all the
sl@0	1562	* information about the command, then additional space is
sl@0	1563	* malloc-ed. If the procedure returns TCL_OK then the caller must
sl@0	1564	* eventually invoke Tcl_FreeParse to release any additional space
sl@0	1565	* that was allocated.
sl@0	1566	*
sl@0	1567	*----------------------------------------------------------------------
sl@0	1568	*/
sl@0	1569
sl@0	1570	EXPORT_C int
sl@0	1571	Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
sl@0	1572	Tcl_Interp interp; / Interpreter to use for error reporting;
sl@0	1573	* if NULL, then no error message is
sl@0	1574	* provided. */
sl@0	1575	CONST char string; / String containing the quoted string.
sl@0	1576	* The first character must be '"'. */
sl@0	1577	register int numBytes; /* Total number of bytes in string. If < 0,
sl@0	1578	* the string consists of all bytes up to
sl@0	1579	* the first null character. */
sl@0	1580	register Tcl_Parse *parsePtr;
sl@0	1581	/* Structure to fill in with information
sl@0	1582	* about the string. */
sl@0	1583	int append; /* Non-zero means append tokens to existing
sl@0	1584	* information in parsePtr; zero means
sl@0	1585	* ignore existing tokens in parsePtr and
sl@0	1586	* reinitialize it. */
sl@0	1587	CONST char *termPtr; / If non-NULL, points to word in which to
sl@0	1588	* store a pointer to the character just
sl@0	1589	* after the quoted string's terminating
sl@0	1590	* close-quote if the parse succeeds. */
sl@0	1591	{
sl@0	1592	if ((numBytes == 0) \|\| (string == NULL)) {
sl@0	1593	return TCL_ERROR;
sl@0	1594	}
sl@0	1595	if (numBytes < 0) {
sl@0	1596	numBytes = strlen(string);
sl@0	1597	}
sl@0	1598
sl@0	1599	if (!append) {
sl@0	1600	parsePtr->numWords = 0;
sl@0	1601	parsePtr->tokenPtr = parsePtr->staticTokens;
sl@0	1602	parsePtr->numTokens = 0;
sl@0	1603	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
sl@0	1604	parsePtr->string = string;
sl@0	1605	parsePtr->end = (string + numBytes);
sl@0	1606	parsePtr->interp = interp;
sl@0	1607	parsePtr->errorType = TCL_PARSE_SUCCESS;
sl@0	1608	}
sl@0	1609
sl@0	1610	if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
sl@0	1611	goto error;
sl@0	1612	}
sl@0	1613	if (*parsePtr->term != '"') {
sl@0	1614	if (interp != NULL) {
sl@0	1615	Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
sl@0	1616	}
sl@0	1617	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
sl@0	1618	parsePtr->term = string;
sl@0	1619	parsePtr->incomplete = 1;
sl@0	1620	goto error;
sl@0	1621	}
sl@0	1622	if (termPtr != NULL) {
sl@0	1623	*termPtr = (parsePtr->term + 1);
sl@0	1624	}
sl@0	1625	return TCL_OK;
sl@0	1626
sl@0	1627	error:
sl@0	1628	Tcl_FreeParse(parsePtr);
sl@0	1629	return TCL_ERROR;
sl@0	1630	}
sl@0	1631
sl@0	1632	/*
sl@0	1633	*----------------------------------------------------------------------
sl@0	1634	*
sl@0	1635	* CommandComplete --
sl@0	1636	*
sl@0	1637	* This procedure is shared by TclCommandComplete and
sl@0	1638	* Tcl_ObjCommandcoComplete; it does all the real work of seeing
sl@0	1639	* whether a script is complete
sl@0	1640	*
sl@0	1641	* Results:
sl@0	1642	* 1 is returned if the script is complete, 0 if there are open
sl@0	1643	* delimiters such as " or (. 1 is also returned if there is a
sl@0	1644	* parse error in the script other than unmatched delimiters.
sl@0	1645	*
sl@0	1646	* Side effects:
sl@0	1647	* None.
sl@0	1648	*
sl@0	1649	*----------------------------------------------------------------------
sl@0	1650	*/
sl@0	1651
sl@0	1652	static int
sl@0	1653	CommandComplete(script, numBytes)
sl@0	1654	CONST char script; / Script to check. */
sl@0	1655	int numBytes; /* Number of bytes in script. */
sl@0	1656	{
sl@0	1657	Tcl_Parse parse;
sl@0	1658	CONST char p, end;
sl@0	1659	int result;
sl@0	1660
sl@0	1661	p = script;
sl@0	1662	end = p + numBytes;
sl@0	1663	while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
sl@0	1664	== TCL_OK) {
sl@0	1665	p = parse.commandStart + parse.commandSize;
sl@0	1666	if (p >= end) {
sl@0	1667	break;
sl@0	1668	}
sl@0	1669	Tcl_FreeParse(&parse);
sl@0	1670	}
sl@0	1671	if (parse.incomplete) {
sl@0	1672	result = 0;
sl@0	1673	} else {
sl@0	1674	result = 1;
sl@0	1675	}
sl@0	1676	Tcl_FreeParse(&parse);
sl@0	1677	return result;
sl@0	1678	}
sl@0	1679
sl@0	1680	/*
sl@0	1681	*----------------------------------------------------------------------
sl@0	1682	*
sl@0	1683	* Tcl_CommandComplete --
sl@0	1684	*
sl@0	1685	* Given a partial or complete Tcl script, this procedure
sl@0	1686	* determines whether the script is complete in the sense
sl@0	1687	* of having matched braces and quotes and brackets.
sl@0	1688	*
sl@0	1689	* Results:
sl@0	1690	* 1 is returned if the script is complete, 0 otherwise.
sl@0	1691	* 1 is also returned if there is a parse error in the script
sl@0	1692	* other than unmatched delimiters.
sl@0	1693	*
sl@0	1694	* Side effects:
sl@0	1695	* None.
sl@0	1696	*
sl@0	1697	*----------------------------------------------------------------------
sl@0	1698	*/
sl@0	1699
sl@0	1700	EXPORT_C int
sl@0	1701	Tcl_CommandComplete(script)
sl@0	1702	CONST char script; / Script to check. */
sl@0	1703	{
sl@0	1704	return CommandComplete(script, (int) strlen(script));
sl@0	1705	}
sl@0	1706
sl@0	1707	/*
sl@0	1708	*----------------------------------------------------------------------
sl@0	1709	*
sl@0	1710	* TclObjCommandComplete --
sl@0	1711	*
sl@0	1712	* Given a partial or complete Tcl command in a Tcl object, this
sl@0	1713	* procedure determines whether the command is complete in the sense of
sl@0	1714	* having matched braces and quotes and brackets.
sl@0	1715	*
sl@0	1716	* Results:
sl@0	1717	* 1 is returned if the command is complete, 0 otherwise.
sl@0	1718	*
sl@0	1719	* Side effects:
sl@0	1720	* None.
sl@0	1721	*
sl@0	1722	*----------------------------------------------------------------------
sl@0	1723	*/
sl@0	1724
sl@0	1725	int
sl@0	1726	TclObjCommandComplete(objPtr)
sl@0	1727	Tcl_Obj objPtr; / Points to object holding script
sl@0	1728	* to check. */
sl@0	1729	{
sl@0	1730	CONST char *script;
sl@0	1731	int length;
sl@0	1732
sl@0	1733	script = Tcl_GetStringFromObj(objPtr, &length);
sl@0	1734	return CommandComplete(script, length);
sl@0	1735	}
sl@0	1736
sl@0	1737	/*
sl@0	1738	*----------------------------------------------------------------------
sl@0	1739	*
sl@0	1740	* TclIsLocalScalar --
sl@0	1741	*
sl@0	1742	* Check to see if a given string is a legal scalar variable
sl@0	1743	* name with no namespace qualifiers or substitutions.
sl@0	1744	*
sl@0	1745	* Results:
sl@0	1746	* Returns 1 if the variable is a local scalar.
sl@0	1747	*
sl@0	1748	* Side effects:
sl@0	1749	* None.
sl@0	1750	*
sl@0	1751	*----------------------------------------------------------------------
sl@0	1752	*/
sl@0	1753
sl@0	1754	int
sl@0	1755	TclIsLocalScalar(src, len)
sl@0	1756	CONST char *src;
sl@0	1757	int len;
sl@0	1758	{
sl@0	1759	CONST char *p;
sl@0	1760	CONST char *lastChar = src + (len - 1);
sl@0	1761
sl@0	1762	for (p = src; p <= lastChar; p++) {
sl@0	1763	if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
sl@0	1764	(CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
sl@0	1765	/*
sl@0	1766	* TCL_COMMAND_END is returned for the last character
sl@0	1767	* of the string. By this point we know it isn't
sl@0	1768	* an array or namespace reference.
sl@0	1769	*/
sl@0	1770
sl@0	1771	return 0;
sl@0	1772	}
sl@0	1773	if (*p == '(') {
sl@0	1774	if (lastChar == ')') { / we have an array element */
sl@0	1775	return 0;
sl@0	1776	}
sl@0	1777	} else if (*p == ':') {
sl@0	1778	if ((p != lastChar) && (p+1) == ':') { / qualified name */
sl@0	1779	return 0;
sl@0	1780	}
sl@0	1781	}
sl@0	1782	}
sl@0	1783
sl@0	1784	return 1;
sl@0	1785	}

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--