Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCmdAH.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclCmdAH.c --
sl@0	3	*
sl@0	4	* This file contains the top-level command routines for most of
sl@0	5	* the Tcl built-in commands whose names begin with the letters
sl@0	6	* A to H.
sl@0	7	*
sl@0	8	* Copyright (c) 1987-1993 The Regents of the University of California.
sl@0	9	* Copyright (c) 1994-1997 Sun Microsystems, Inc.
sl@0	10	* Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	11	*
sl@0	12	* See the file "license.terms" for information on usage and redistribution
sl@0	13	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	14	*
sl@0	15	* RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $
sl@0	16	*/
sl@0	17
sl@0	18	#include "tclInt.h"
sl@0	19	#include "tclPort.h"
sl@0	20	#include <locale.h>
sl@0	21	#if defined(__SYMBIAN32__)
sl@0	22	#include "tclSymbianGlobals.h"
sl@0	23	#endif
sl@0	24
sl@0	25	/*
sl@0	26	* Prototypes for local procedures defined in this file:
sl@0	27	*/
sl@0	28
sl@0	29	static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	30	Tcl_Obj *objPtr, int mode));
sl@0	31	static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	32	Tcl_Obj objPtr, Tcl_FSStatProc statProc,
sl@0	33	Tcl_StatBuf *statPtr));
sl@0	34	static char * GetTypeFromMode _ANSI_ARGS_((int mode));
sl@0	35	static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	36	char varName, Tcl_StatBuf statPtr));
sl@0	37
sl@0	38	/*
sl@0	39	*----------------------------------------------------------------------
sl@0	40	*
sl@0	41	* Tcl_BreakObjCmd --
sl@0	42	*
sl@0	43	* This procedure is invoked to process the "break" Tcl command.
sl@0	44	* See the user documentation for details on what it does.
sl@0	45	*
sl@0	46	* With the bytecode compiler, this procedure is only called when
sl@0	47	* a command name is computed at runtime, and is "break" or the name
sl@0	48	* to which "break" was renamed: e.g., "set z break; $z"
sl@0	49	*
sl@0	50	* Results:
sl@0	51	* A standard Tcl result.
sl@0	52	*
sl@0	53	* Side effects:
sl@0	54	* See the user documentation.
sl@0	55	*
sl@0	56	*----------------------------------------------------------------------
sl@0	57	*/
sl@0	58
sl@0	59	/* ARGSUSED */
sl@0	60	int
sl@0	61	Tcl_BreakObjCmd(dummy, interp, objc, objv)
sl@0	62	ClientData dummy; /* Not used. */
sl@0	63	Tcl_Interp interp; / Current interpreter. */
sl@0	64	int objc; /* Number of arguments. */
sl@0	65	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	66	{
sl@0	67	if (objc != 1) {
sl@0	68	Tcl_WrongNumArgs(interp, 1, objv, NULL);
sl@0	69	return TCL_ERROR;
sl@0	70	}
sl@0	71	return TCL_BREAK;
sl@0	72	}
sl@0	73
sl@0	74	/*
sl@0	75	*----------------------------------------------------------------------
sl@0	76	*
sl@0	77	* Tcl_CaseObjCmd --
sl@0	78	*
sl@0	79	* This procedure is invoked to process the "case" Tcl command.
sl@0	80	* See the user documentation for details on what it does.
sl@0	81	*
sl@0	82	* Results:
sl@0	83	* A standard Tcl object result.
sl@0	84	*
sl@0	85	* Side effects:
sl@0	86	* See the user documentation.
sl@0	87	*
sl@0	88	*----------------------------------------------------------------------
sl@0	89	*/
sl@0	90
sl@0	91	/* ARGSUSED */
sl@0	92	int
sl@0	93	Tcl_CaseObjCmd(dummy, interp, objc, objv)
sl@0	94	ClientData dummy; /* Not used. */
sl@0	95	Tcl_Interp interp; / Current interpreter. */
sl@0	96	int objc; /* Number of arguments. */
sl@0	97	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	98	{
sl@0	99	register int i;
sl@0	100	int body, result, caseObjc;
sl@0	101	char string, arg;
sl@0	102	Tcl_Obj CONST caseObjv;
sl@0	103	Tcl_Obj *armPtr;
sl@0	104
sl@0	105	if (objc < 3) {
sl@0	106	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	107	"string ?in? patList body ... ?default body?");
sl@0	108	return TCL_ERROR;
sl@0	109	}
sl@0	110
sl@0	111	string = Tcl_GetString(objv[1]);
sl@0	112	body = -1;
sl@0	113
sl@0	114	arg = Tcl_GetString(objv[2]);
sl@0	115	if (strcmp(arg, "in") == 0) {
sl@0	116	i = 3;
sl@0	117	} else {
sl@0	118	i = 2;
sl@0	119	}
sl@0	120	caseObjc = objc - i;
sl@0	121	caseObjv = objv + i;
sl@0	122
sl@0	123	/*
sl@0	124	* If all of the pattern/command pairs are lumped into a single
sl@0	125	* argument, split them out again.
sl@0	126	*/
sl@0	127
sl@0	128	if (caseObjc == 1) {
sl@0	129	Tcl_Obj **newObjv;
sl@0	130
sl@0	131	Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
sl@0	132	caseObjv = newObjv;
sl@0	133	}
sl@0	134
sl@0	135	for (i = 0; i < caseObjc; i += 2) {
sl@0	136	int patObjc, j;
sl@0	137	CONST char **patObjv;
sl@0	138	char *pat;
sl@0	139	unsigned char *p;
sl@0	140
sl@0	141	if (i == (caseObjc - 1)) {
sl@0	142	Tcl_ResetResult(interp);
sl@0	143	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	144	"extra case pattern with no body", -1);
sl@0	145	return TCL_ERROR;
sl@0	146	}
sl@0	147
sl@0	148	/*
sl@0	149	* Check for special case of single pattern (no list) with
sl@0	150	* no backslash sequences.
sl@0	151	*/
sl@0	152
sl@0	153	pat = Tcl_GetString(caseObjv[i]);
sl@0	154	for (p = (unsigned char ) pat; p != '\0'; p++) {
sl@0	155	if (isspace(p) \|\| (p == '\\')) { /* INTL: ISO space, UCHAR */
sl@0	156	break;
sl@0	157	}
sl@0	158	}
sl@0	159	if (*p == '\0') {
sl@0	160	if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
sl@0	161	body = i + 1;
sl@0	162	}
sl@0	163	if (Tcl_StringMatch(string, pat)) {
sl@0	164	body = i + 1;
sl@0	165	goto match;
sl@0	166	}
sl@0	167	continue;
sl@0	168	}
sl@0	169
sl@0	170
sl@0	171	/*
sl@0	172	* Break up pattern lists, then check each of the patterns
sl@0	173	* in the list.
sl@0	174	*/
sl@0	175
sl@0	176	result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
sl@0	177	if (result != TCL_OK) {
sl@0	178	return result;
sl@0	179	}
sl@0	180	for (j = 0; j < patObjc; j++) {
sl@0	181	if (Tcl_StringMatch(string, patObjv[j])) {
sl@0	182	body = i + 1;
sl@0	183	break;
sl@0	184	}
sl@0	185	}
sl@0	186	ckfree((char *) patObjv);
sl@0	187	if (j < patObjc) {
sl@0	188	break;
sl@0	189	}
sl@0	190	}
sl@0	191
sl@0	192	match:
sl@0	193	if (body != -1) {
sl@0	194	armPtr = caseObjv[body - 1];
sl@0	195	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
sl@0	196	if (result == TCL_ERROR) {
sl@0	197	char msg[100 + TCL_INTEGER_SPACE];
sl@0	198
sl@0	199	arg = Tcl_GetString(armPtr);
sl@0	200	sprintf(msg,
sl@0	201	"\n (\"%.50s\" arm line %d)", arg,
sl@0	202	interp->errorLine);
sl@0	203	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	204	}
sl@0	205	return result;
sl@0	206	}
sl@0	207
sl@0	208	/*
sl@0	209	* Nothing matched: return nothing.
sl@0	210	*/
sl@0	211
sl@0	212	return TCL_OK;
sl@0	213	}
sl@0	214
sl@0	215	/*
sl@0	216	*----------------------------------------------------------------------
sl@0	217	*
sl@0	218	* Tcl_CatchObjCmd --
sl@0	219	*
sl@0	220	* This object-based procedure is invoked to process the "catch" Tcl
sl@0	221	* command. See the user documentation for details on what it does.
sl@0	222	*
sl@0	223	* Results:
sl@0	224	* A standard Tcl object result.
sl@0	225	*
sl@0	226	* Side effects:
sl@0	227	* See the user documentation.
sl@0	228	*
sl@0	229	*----------------------------------------------------------------------
sl@0	230	*/
sl@0	231
sl@0	232	/* ARGSUSED */
sl@0	233	int
sl@0	234	Tcl_CatchObjCmd(dummy, interp, objc, objv)
sl@0	235	ClientData dummy; /* Not used. */
sl@0	236	Tcl_Interp interp; / Current interpreter. */
sl@0	237	int objc; /* Number of arguments. */
sl@0	238	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	239	{
sl@0	240	Tcl_Obj *varNamePtr = NULL;
sl@0	241	int result;
sl@0	242	#ifdef TCL_TIP280
sl@0	243	Interp* iPtr = (Interp*) interp;
sl@0	244	#endif
sl@0	245
sl@0	246	if ((objc != 2) && (objc != 3)) {
sl@0	247	Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
sl@0	248	return TCL_ERROR;
sl@0	249	}
sl@0	250
sl@0	251	if (objc == 3) {
sl@0	252	varNamePtr = objv[2];
sl@0	253	}
sl@0	254
sl@0	255	#ifndef TCL_TIP280
sl@0	256	result = Tcl_EvalObjEx(interp, objv[1], 0);
sl@0	257	#else
sl@0	258	/* TIP #280. Make invoking context available to caught script */
sl@0	259	result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
sl@0	260	#endif
sl@0	261
sl@0	262	if (objc == 3) {
sl@0	263	if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
sl@0	264	Tcl_GetObjResult(interp), 0) == NULL) {
sl@0	265	Tcl_ResetResult(interp);
sl@0	266	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	267	"couldn't save command result in variable", -1);
sl@0	268	return TCL_ERROR;
sl@0	269	}
sl@0	270	}
sl@0	271
sl@0	272	/*
sl@0	273	* Set the interpreter's object result to an integer object holding the
sl@0	274	* integer Tcl_EvalObj result. Note that we don't bother generating a
sl@0	275	* string representation. We reset the interpreter's object result
sl@0	276	* to an unshared empty object and then set it to be an integer object.
sl@0	277	*/
sl@0	278
sl@0	279	Tcl_ResetResult(interp);
sl@0	280	Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
sl@0	281	return TCL_OK;
sl@0	282	}
sl@0	283
sl@0	284	/*
sl@0	285	*----------------------------------------------------------------------
sl@0	286	*
sl@0	287	* Tcl_CdObjCmd --
sl@0	288	*
sl@0	289	* This procedure is invoked to process the "cd" Tcl command.
sl@0	290	* See the user documentation for details on what it does.
sl@0	291	*
sl@0	292	* Results:
sl@0	293	* A standard Tcl result.
sl@0	294	*
sl@0	295	* Side effects:
sl@0	296	* See the user documentation.
sl@0	297	*
sl@0	298	*----------------------------------------------------------------------
sl@0	299	*/
sl@0	300
sl@0	301	/* ARGSUSED */
sl@0	302	int
sl@0	303	Tcl_CdObjCmd(dummy, interp, objc, objv)
sl@0	304	ClientData dummy; /* Not used. */
sl@0	305	Tcl_Interp interp; / Current interpreter. */
sl@0	306	int objc; /* Number of arguments. */
sl@0	307	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	308	{
sl@0	309	Tcl_Obj *dir;
sl@0	310	int result;
sl@0	311
sl@0	312	if (objc > 2) {
sl@0	313	Tcl_WrongNumArgs(interp, 1, objv, "?dirName?");
sl@0	314	return TCL_ERROR;
sl@0	315	}
sl@0	316
sl@0	317	if (objc == 2) {
sl@0	318	dir = objv[1];
sl@0	319	} else {
sl@0	320	dir = Tcl_NewStringObj("~",1);
sl@0	321	Tcl_IncrRefCount(dir);
sl@0	322	}
sl@0	323	if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
sl@0	324	result = TCL_ERROR;
sl@0	325	} else {
sl@0	326	result = Tcl_FSChdir(dir);
sl@0	327	if (result != TCL_OK) {
sl@0	328	Tcl_AppendResult(interp, "couldn't change working directory to \"",
sl@0	329	Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);
sl@0	330	result = TCL_ERROR;
sl@0	331	}
sl@0	332	}
sl@0	333	if (objc != 2) {
sl@0	334	Tcl_DecrRefCount(dir);
sl@0	335	}
sl@0	336	return result;
sl@0	337	}
sl@0	338
sl@0	339	/*
sl@0	340	*----------------------------------------------------------------------
sl@0	341	*
sl@0	342	* Tcl_ConcatObjCmd --
sl@0	343	*
sl@0	344	* This object-based procedure is invoked to process the "concat" Tcl
sl@0	345	* command. See the user documentation for details on what it does.
sl@0	346	*
sl@0	347	* Results:
sl@0	348	* A standard Tcl object result.
sl@0	349	*
sl@0	350	* Side effects:
sl@0	351	* See the user documentation.
sl@0	352	*
sl@0	353	*----------------------------------------------------------------------
sl@0	354	*/
sl@0	355
sl@0	356	/* ARGSUSED */
sl@0	357	int
sl@0	358	Tcl_ConcatObjCmd(dummy, interp, objc, objv)
sl@0	359	ClientData dummy; /* Not used. */
sl@0	360	Tcl_Interp interp; / Current interpreter. */
sl@0	361	int objc; /* Number of arguments. */
sl@0	362	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	363	{
sl@0	364	if (objc >= 2) {
sl@0	365	Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
sl@0	366	}
sl@0	367	return TCL_OK;
sl@0	368	}
sl@0	369
sl@0	370	/*
sl@0	371	*----------------------------------------------------------------------
sl@0	372	*
sl@0	373	* Tcl_ContinueObjCmd -
sl@0	374	*
sl@0	375	* This procedure is invoked to process the "continue" Tcl command.
sl@0	376	* See the user documentation for details on what it does.
sl@0	377	*
sl@0	378	* With the bytecode compiler, this procedure is only called when
sl@0	379	* a command name is computed at runtime, and is "continue" or the name
sl@0	380	* to which "continue" was renamed: e.g., "set z continue; $z"
sl@0	381	*
sl@0	382	* Results:
sl@0	383	* A standard Tcl result.
sl@0	384	*
sl@0	385	* Side effects:
sl@0	386	* See the user documentation.
sl@0	387	*
sl@0	388	*----------------------------------------------------------------------
sl@0	389	*/
sl@0	390
sl@0	391	/* ARGSUSED */
sl@0	392	int
sl@0	393	Tcl_ContinueObjCmd(dummy, interp, objc, objv)
sl@0	394	ClientData dummy; /* Not used. */
sl@0	395	Tcl_Interp interp; / Current interpreter. */
sl@0	396	int objc; /* Number of arguments. */
sl@0	397	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	398	{
sl@0	399	if (objc != 1) {
sl@0	400	Tcl_WrongNumArgs(interp, 1, objv, NULL);
sl@0	401	return TCL_ERROR;
sl@0	402	}
sl@0	403	return TCL_CONTINUE;
sl@0	404	}
sl@0	405
sl@0	406	/*
sl@0	407	*----------------------------------------------------------------------
sl@0	408	*
sl@0	409	* Tcl_EncodingObjCmd --
sl@0	410	*
sl@0	411	* This command manipulates encodings.
sl@0	412	*
sl@0	413	* Results:
sl@0	414	* A standard Tcl result.
sl@0	415	*
sl@0	416	* Side effects:
sl@0	417	* See the user documentation.
sl@0	418	*
sl@0	419	*----------------------------------------------------------------------
sl@0	420	*/
sl@0	421
sl@0	422	int
sl@0	423	Tcl_EncodingObjCmd(dummy, interp, objc, objv)
sl@0	424	ClientData dummy; /* Not used. */
sl@0	425	Tcl_Interp interp; / Current interpreter. */
sl@0	426	int objc; /* Number of arguments. */
sl@0	427	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	428	{
sl@0	429	int index, length;
sl@0	430	Tcl_Encoding encoding;
sl@0	431	char *string;
sl@0	432	Tcl_DString ds;
sl@0	433	Tcl_Obj *resultPtr;
sl@0	434
sl@0	435	static CONST char *optionStrings[] = {
sl@0	436	"convertfrom", "convertto", "names", "system",
sl@0	437	NULL
sl@0	438	};
sl@0	439	enum options {
sl@0	440	ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
sl@0	441	};
sl@0	442
sl@0	443	if (objc < 2) {
sl@0	444	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
sl@0	445	return TCL_ERROR;
sl@0	446	}
sl@0	447	if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
sl@0	448	&index) != TCL_OK) {
sl@0	449	return TCL_ERROR;
sl@0	450	}
sl@0	451
sl@0	452	switch ((enum options) index) {
sl@0	453	case ENC_CONVERTTO:
sl@0	454	case ENC_CONVERTFROM: {
sl@0	455	Tcl_Obj *data;
sl@0	456	if (objc == 3) {
sl@0	457	encoding = Tcl_GetEncoding(interp, NULL);
sl@0	458	data = objv[2];
sl@0	459	} else if (objc == 4) {
sl@0	460	if (TclGetEncodingFromObj(interp, objv[2], &encoding)
sl@0	461	!= TCL_OK) {
sl@0	462	return TCL_ERROR;
sl@0	463	}
sl@0	464	data = objv[3];
sl@0	465	} else {
sl@0	466	Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
sl@0	467	return TCL_ERROR;
sl@0	468	}
sl@0	469
sl@0	470	if ((enum options) index == ENC_CONVERTFROM) {
sl@0	471	/*
sl@0	472	* Treat the string as binary data.
sl@0	473	*/
sl@0	474
sl@0	475	string = (char *) Tcl_GetByteArrayFromObj(data, &length);
sl@0	476	Tcl_ExternalToUtfDString(encoding, string, length, &ds);
sl@0	477
sl@0	478	/*
sl@0	479	* Note that we cannot use Tcl_DStringResult here because
sl@0	480	* it will truncate the string at the first null byte.
sl@0	481	*/
sl@0	482
sl@0	483	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	484	Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
sl@0	485	Tcl_DStringFree(&ds);
sl@0	486	} else {
sl@0	487	/*
sl@0	488	* Store the result as binary data.
sl@0	489	*/
sl@0	490
sl@0	491	string = Tcl_GetStringFromObj(data, &length);
sl@0	492	Tcl_UtfToExternalDString(encoding, string, length, &ds);
sl@0	493	resultPtr = Tcl_GetObjResult(interp);
sl@0	494	Tcl_SetByteArrayObj(resultPtr,
sl@0	495	(unsigned char *) Tcl_DStringValue(&ds),
sl@0	496	Tcl_DStringLength(&ds));
sl@0	497	Tcl_DStringFree(&ds);
sl@0	498	}
sl@0	499
sl@0	500	Tcl_FreeEncoding(encoding);
sl@0	501	break;
sl@0	502	}
sl@0	503	case ENC_NAMES: {
sl@0	504	if (objc > 2) {
sl@0	505	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	506	return TCL_ERROR;
sl@0	507	}
sl@0	508	Tcl_GetEncodingNames(interp);
sl@0	509	break;
sl@0	510	}
sl@0	511	case ENC_SYSTEM: {
sl@0	512	if (objc > 3) {
sl@0	513	Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
sl@0	514	return TCL_ERROR;
sl@0	515	}
sl@0	516	if (objc == 2) {
sl@0	517	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	518	Tcl_GetEncodingName(NULL), -1);
sl@0	519	} else {
sl@0	520	return Tcl_SetSystemEncoding(interp,
sl@0	521	Tcl_GetStringFromObj(objv[2], NULL));
sl@0	522	}
sl@0	523	break;
sl@0	524	}
sl@0	525	}
sl@0	526	return TCL_OK;
sl@0	527	}
sl@0	528
sl@0	529	/*
sl@0	530	*----------------------------------------------------------------------
sl@0	531	*
sl@0	532	* Tcl_ErrorObjCmd --
sl@0	533	*
sl@0	534	* This procedure is invoked to process the "error" Tcl command.
sl@0	535	* See the user documentation for details on what it does.
sl@0	536	*
sl@0	537	* Results:
sl@0	538	* A standard Tcl object result.
sl@0	539	*
sl@0	540	* Side effects:
sl@0	541	* See the user documentation.
sl@0	542	*
sl@0	543	*----------------------------------------------------------------------
sl@0	544	*/
sl@0	545
sl@0	546	/* ARGSUSED */
sl@0	547	int
sl@0	548	Tcl_ErrorObjCmd(dummy, interp, objc, objv)
sl@0	549	ClientData dummy; /* Not used. */
sl@0	550	Tcl_Interp interp; / Current interpreter. */
sl@0	551	int objc; /* Number of arguments. */
sl@0	552	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	553	{
sl@0	554	Interp iPtr = (Interp ) interp;
sl@0	555	char *info;
sl@0	556	int infoLen;
sl@0	557
sl@0	558	if ((objc < 2) \|\| (objc > 4)) {
sl@0	559	Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
sl@0	560	return TCL_ERROR;
sl@0	561	}
sl@0	562
sl@0	563	if (objc >= 3) { /* process the optional info argument */
sl@0	564	info = Tcl_GetStringFromObj(objv[2], &infoLen);
sl@0	565	if (infoLen > 0) {
sl@0	566	Tcl_AddObjErrorInfo(interp, info, infoLen);
sl@0	567	iPtr->flags \|= ERR_ALREADY_LOGGED;
sl@0	568	}
sl@0	569	}
sl@0	570
sl@0	571	if (objc == 4) {
sl@0	572	Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
sl@0	573	iPtr->flags \|= ERROR_CODE_SET;
sl@0	574	}
sl@0	575
sl@0	576	Tcl_SetObjResult(interp, objv[1]);
sl@0	577	return TCL_ERROR;
sl@0	578	}
sl@0	579
sl@0	580	/*
sl@0	581	*----------------------------------------------------------------------
sl@0	582	*
sl@0	583	* Tcl_EvalObjCmd --
sl@0	584	*
sl@0	585	* This object-based procedure is invoked to process the "eval" Tcl
sl@0	586	* command. See the user documentation for details on what it does.
sl@0	587	*
sl@0	588	* Results:
sl@0	589	* A standard Tcl object result.
sl@0	590	*
sl@0	591	* Side effects:
sl@0	592	* See the user documentation.
sl@0	593	*
sl@0	594	*----------------------------------------------------------------------
sl@0	595	*/
sl@0	596
sl@0	597	/* ARGSUSED */
sl@0	598	int
sl@0	599	Tcl_EvalObjCmd(dummy, interp, objc, objv)
sl@0	600	ClientData dummy; /* Not used. */
sl@0	601	Tcl_Interp interp; / Current interpreter. */
sl@0	602	int objc; /* Number of arguments. */
sl@0	603	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	604	{
sl@0	605	int result;
sl@0	606	register Tcl_Obj *objPtr;
sl@0	607	#ifdef TCL_TIP280
sl@0	608	Interp* iPtr = (Interp*) interp;
sl@0	609	#endif
sl@0	610
sl@0	611	if (objc < 2) {
sl@0	612	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
sl@0	613	return TCL_ERROR;
sl@0	614	}
sl@0	615
sl@0	616	if (objc == 2) {
sl@0	617	#ifndef TCL_TIP280
sl@0	618	result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
sl@0	619	#else
sl@0	620	/* TIP #280. Make invoking context available to eval'd script */
sl@0	621	result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
sl@0	622	iPtr->cmdFramePtr,1);
sl@0	623	#endif
sl@0	624	} else {
sl@0	625	/*
sl@0	626	* More than one argument: concatenate them together with spaces
sl@0	627	* between, then evaluate the result. Tcl_EvalObjEx will delete
sl@0	628	* the object when it decrements its refcount after eval'ing it.
sl@0	629	*/
sl@0	630	objPtr = Tcl_ConcatObj(objc-1, objv+1);
sl@0	631	#ifndef TCL_TIP280
sl@0	632	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
sl@0	633	#else
sl@0	634	/* TIP #280. Make invoking context available to eval'd script */
sl@0	635	result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
sl@0	636	#endif
sl@0	637	}
sl@0	638	if (result == TCL_ERROR) {
sl@0	639	char msg[32 + TCL_INTEGER_SPACE];
sl@0	640
sl@0	641	sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
sl@0	642	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	643	}
sl@0	644	return result;
sl@0	645	}
sl@0	646
sl@0	647	/*
sl@0	648	*----------------------------------------------------------------------
sl@0	649	*
sl@0	650	* Tcl_ExitObjCmd --
sl@0	651	*
sl@0	652	* This procedure is invoked to process the "exit" Tcl command.
sl@0	653	* See the user documentation for details on what it does.
sl@0	654	*
sl@0	655	* Results:
sl@0	656	* A standard Tcl object result.
sl@0	657	*
sl@0	658	* Side effects:
sl@0	659	* See the user documentation.
sl@0	660	*
sl@0	661	*----------------------------------------------------------------------
sl@0	662	*/
sl@0	663
sl@0	664	/* ARGSUSED */
sl@0	665	int
sl@0	666	Tcl_ExitObjCmd(dummy, interp, objc, objv)
sl@0	667	ClientData dummy; /* Not used. */
sl@0	668	Tcl_Interp interp; / Current interpreter. */
sl@0	669	int objc; /* Number of arguments. */
sl@0	670	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	671	{
sl@0	672	int value;
sl@0	673
sl@0	674	if ((objc != 1) && (objc != 2)) {
sl@0	675	Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
sl@0	676	return TCL_ERROR;
sl@0	677	}
sl@0	678
sl@0	679	if (objc == 1) {
sl@0	680	value = 0;
sl@0	681	} else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
sl@0	682	return TCL_ERROR;
sl@0	683	}
sl@0	684	Tcl_Exit(value);
sl@0	685	/NOTREACHED/
sl@0	686	return TCL_OK; /* Better not ever reach this! */
sl@0	687	}
sl@0	688
sl@0	689	/*
sl@0	690	*----------------------------------------------------------------------
sl@0	691	*
sl@0	692	* Tcl_ExprObjCmd --
sl@0	693	*
sl@0	694	* This object-based procedure is invoked to process the "expr" Tcl
sl@0	695	* command. See the user documentation for details on what it does.
sl@0	696	*
sl@0	697	* With the bytecode compiler, this procedure is called in two
sl@0	698	* circumstances: 1) to execute expr commands that are too complicated
sl@0	699	* or too unsafe to try compiling directly into an inline sequence of
sl@0	700	* instructions, and 2) to execute commands where the command name is
sl@0	701	* computed at runtime and is "expr" or the name to which "expr" was
sl@0	702	* renamed (e.g., "set z expr; $z 2+3")
sl@0	703	*
sl@0	704	* Results:
sl@0	705	* A standard Tcl object result.
sl@0	706	*
sl@0	707	* Side effects:
sl@0	708	* See the user documentation.
sl@0	709	*
sl@0	710	*----------------------------------------------------------------------
sl@0	711	*/
sl@0	712
sl@0	713	/* ARGSUSED */
sl@0	714	int
sl@0	715	Tcl_ExprObjCmd(dummy, interp, objc, objv)
sl@0	716	ClientData dummy; /* Not used. */
sl@0	717	Tcl_Interp interp; / Current interpreter. */
sl@0	718	int objc; /* Number of arguments. */
sl@0	719	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	720	{
sl@0	721	register Tcl_Obj *objPtr;
sl@0	722	Tcl_Obj *resultPtr;
sl@0	723	register char *bytes;
sl@0	724	int length, i, result;
sl@0	725
sl@0	726	if (objc < 2) {
sl@0	727	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
sl@0	728	return TCL_ERROR;
sl@0	729	}
sl@0	730
sl@0	731	if (objc == 2) {
sl@0	732	result = Tcl_ExprObj(interp, objv[1], &resultPtr);
sl@0	733	if (result == TCL_OK) {
sl@0	734	Tcl_SetObjResult(interp, resultPtr);
sl@0	735	Tcl_DecrRefCount(resultPtr); /* done with the result object */
sl@0	736	}
sl@0	737	return result;
sl@0	738	}
sl@0	739
sl@0	740	/*
sl@0	741	* Create a new object holding the concatenated argument strings.
sl@0	742	*/
sl@0	743
sl@0	744	/* QUESTION: Do we need to copy the slow way? */
sl@0	745	bytes = Tcl_GetStringFromObj(objv[1], &length);
sl@0	746	objPtr = Tcl_NewStringObj(bytes, length);
sl@0	747	Tcl_IncrRefCount(objPtr);
sl@0	748	for (i = 2; i < objc; i++) {
sl@0	749	Tcl_AppendToObj(objPtr, " ", 1);
sl@0	750	bytes = Tcl_GetStringFromObj(objv[i], &length);
sl@0	751	Tcl_AppendToObj(objPtr, bytes, length);
sl@0	752	}
sl@0	753
sl@0	754	/*
sl@0	755	* Evaluate the concatenated string object.
sl@0	756	*/
sl@0	757
sl@0	758	result = Tcl_ExprObj(interp, objPtr, &resultPtr);
sl@0	759	if (result == TCL_OK) {
sl@0	760	Tcl_SetObjResult(interp, resultPtr);
sl@0	761	Tcl_DecrRefCount(resultPtr); /* done with the result object */
sl@0	762	}
sl@0	763
sl@0	764	/*
sl@0	765	* Free allocated resources.
sl@0	766	*/
sl@0	767
sl@0	768	Tcl_DecrRefCount(objPtr);
sl@0	769	return result;
sl@0	770	}
sl@0	771
sl@0	772	/*
sl@0	773	*----------------------------------------------------------------------
sl@0	774	*
sl@0	775	* Tcl_FileObjCmd --
sl@0	776	*
sl@0	777	* This procedure is invoked to process the "file" Tcl command.
sl@0	778	* See the user documentation for details on what it does.
sl@0	779	* PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
sl@0	780	* EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
sl@0	781	* With the object-based Tcl_FS APIs, the above NOTE may no
sl@0	782	* longer be true. In any case this assertion should be tested.
sl@0	783	*
sl@0	784	* Results:
sl@0	785	* A standard Tcl result.
sl@0	786	*
sl@0	787	* Side effects:
sl@0	788	* See the user documentation.
sl@0	789	*
sl@0	790	*----------------------------------------------------------------------
sl@0	791	*/
sl@0	792
sl@0	793	/* ARGSUSED */
sl@0	794	int
sl@0	795	Tcl_FileObjCmd(dummy, interp, objc, objv)
sl@0	796	ClientData dummy; /* Not used. */
sl@0	797	Tcl_Interp interp; / Current interpreter. */
sl@0	798	int objc; /* Number of arguments. */
sl@0	799	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	800	{
sl@0	801	int index;
sl@0	802
sl@0	803	/*
sl@0	804	* This list of constants should match the fileOption string array below.
sl@0	805	*/
sl@0	806
sl@0	807	static CONST char *fileOptions[] = {
sl@0	808	"atime", "attributes", "channels", "copy",
sl@0	809	"delete",
sl@0	810	"dirname", "executable", "exists", "extension",
sl@0	811	"isdirectory", "isfile", "join", "link",
sl@0	812	"lstat", "mtime", "mkdir", "nativename",
sl@0	813	"normalize", "owned",
sl@0	814	"pathtype", "readable", "readlink", "rename",
sl@0	815	"rootname", "separator", "size", "split",
sl@0	816	"stat", "system",
sl@0	817	"tail", "type", "volumes", "writable",
sl@0	818	(char *) NULL
sl@0	819	};
sl@0	820	enum options {
sl@0	821	FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
sl@0	822	FCMD_DELETE,
sl@0	823	FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
sl@0	824	FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
sl@0	825	FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
sl@0	826	FCMD_NORMALIZE, FCMD_OWNED,
sl@0	827	FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
sl@0	828	FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
sl@0	829	FCMD_STAT, FCMD_SYSTEM,
sl@0	830	FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
sl@0	831	};
sl@0	832
sl@0	833	if (objc < 2) {
sl@0	834	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
sl@0	835	return TCL_ERROR;
sl@0	836	}
sl@0	837	if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
sl@0	838	&index) != TCL_OK) {
sl@0	839	return TCL_ERROR;
sl@0	840	}
sl@0	841
sl@0	842	switch ((enum options) index) {
sl@0	843	case FCMD_ATIME: {
sl@0	844	Tcl_StatBuf buf;
sl@0	845	struct utimbuf tval;
sl@0	846
sl@0	847	if ((objc < 3) \|\| (objc > 4)) {
sl@0	848	Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
sl@0	849	return TCL_ERROR;
sl@0	850	}
sl@0	851	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	852	return TCL_ERROR;
sl@0	853	}
sl@0	854	if (objc == 4) {
sl@0	855	long newTime;
sl@0	856
sl@0	857	if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
sl@0	858	return TCL_ERROR;
sl@0	859	}
sl@0	860	tval.actime = newTime;
sl@0	861	tval.modtime = buf.st_mtime;
sl@0	862	if (Tcl_FSUtime(objv[2], &tval) != 0) {
sl@0	863	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	864	"could not set access time for file \"",
sl@0	865	Tcl_GetString(objv[2]), "\": ",
sl@0	866	Tcl_PosixError(interp), (char *) NULL);
sl@0	867	return TCL_ERROR;
sl@0	868	}
sl@0	869	/*
sl@0	870	* Do another stat to ensure that the we return the
sl@0	871	* new recognized atime - hopefully the same as the
sl@0	872	* one we sent in. However, fs's like FAT don't
sl@0	873	* even know what atime is.
sl@0	874	*/
sl@0	875	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	876	return TCL_ERROR;
sl@0	877	}
sl@0	878	}
sl@0	879	Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
sl@0	880	return TCL_OK;
sl@0	881	}
sl@0	882	case FCMD_ATTRIBUTES: {
sl@0	883	return TclFileAttrsCmd(interp, objc, objv);
sl@0	884	}
sl@0	885	case FCMD_CHANNELS: {
sl@0	886	if ((objc < 2) \|\| (objc > 3)) {
sl@0	887	Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
sl@0	888	return TCL_ERROR;
sl@0	889	}
sl@0	890	return Tcl_GetChannelNamesEx(interp,
sl@0	891	((objc == 2) ? NULL : Tcl_GetString(objv[2])));
sl@0	892	}
sl@0	893	case FCMD_COPY: {
sl@0	894	return TclFileCopyCmd(interp, objc, objv);
sl@0	895	}
sl@0	896	case FCMD_DELETE: {
sl@0	897	return TclFileDeleteCmd(interp, objc, objv);
sl@0	898	}
sl@0	899	case FCMD_DIRNAME: {
sl@0	900	Tcl_Obj *dirPtr;
sl@0	901	if (objc != 3) {
sl@0	902	goto only3Args;
sl@0	903	}
sl@0	904	dirPtr = TclFileDirname(interp, objv[2]);
sl@0	905	if (dirPtr == NULL) {
sl@0	906	return TCL_ERROR;
sl@0	907	} else {
sl@0	908	Tcl_SetObjResult(interp, dirPtr);
sl@0	909	Tcl_DecrRefCount(dirPtr);
sl@0	910	return TCL_OK;
sl@0	911	}
sl@0	912	}
sl@0	913	case FCMD_EXECUTABLE: {
sl@0	914	if (objc != 3) {
sl@0	915	goto only3Args;
sl@0	916	}
sl@0	917	return CheckAccess(interp, objv[2], X_OK);
sl@0	918	}
sl@0	919	case FCMD_EXISTS: {
sl@0	920	if (objc != 3) {
sl@0	921	goto only3Args;
sl@0	922	}
sl@0	923	return CheckAccess(interp, objv[2], F_OK);
sl@0	924	}
sl@0	925	case FCMD_EXTENSION: {
sl@0	926	char fileName, extension;
sl@0	927	if (objc != 3) {
sl@0	928	goto only3Args;
sl@0	929	}
sl@0	930	fileName = Tcl_GetString(objv[2]);
sl@0	931	extension = TclGetExtension(fileName);
sl@0	932	if (extension != NULL) {
sl@0	933	Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
sl@0	934	}
sl@0	935	return TCL_OK;
sl@0	936	}
sl@0	937	case FCMD_ISDIRECTORY: {
sl@0	938	int value;
sl@0	939	Tcl_StatBuf buf;
sl@0	940
sl@0	941	if (objc != 3) {
sl@0	942	goto only3Args;
sl@0	943	}
sl@0	944	value = 0;
sl@0	945	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
sl@0	946	value = S_ISDIR(buf.st_mode);
sl@0	947	}
sl@0	948	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
sl@0	949	return TCL_OK;
sl@0	950	}
sl@0	951	case FCMD_ISFILE: {
sl@0	952	int value;
sl@0	953	Tcl_StatBuf buf;
sl@0	954
sl@0	955	if (objc != 3) {
sl@0	956	goto only3Args;
sl@0	957	}
sl@0	958	value = 0;
sl@0	959	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
sl@0	960	value = S_ISREG(buf.st_mode);
sl@0	961	}
sl@0	962	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
sl@0	963	return TCL_OK;
sl@0	964	}
sl@0	965	case FCMD_JOIN: {
sl@0	966	Tcl_Obj *resObj;
sl@0	967
sl@0	968	if (objc < 3) {
sl@0	969	Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
sl@0	970	return TCL_ERROR;
sl@0	971	}
sl@0	972	resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
sl@0	973	Tcl_SetObjResult(interp, resObj);
sl@0	974	return TCL_OK;
sl@0	975	}
sl@0	976	case FCMD_LINK: {
sl@0	977	Tcl_Obj *contents;
sl@0	978	int index;
sl@0	979
sl@0	980	if (objc < 3 \|\| objc > 5) {
sl@0	981	Tcl_WrongNumArgs(interp, 2, objv,
sl@0	982	"?-linktype? linkname ?target?");
sl@0	983	return TCL_ERROR;
sl@0	984	}
sl@0	985
sl@0	986	/* Index of the 'source' argument */
sl@0	987	if (objc == 5) {
sl@0	988	index = 3;
sl@0	989	} else {
sl@0	990	index = 2;
sl@0	991	}
sl@0	992
sl@0	993	if (objc > 3) {
sl@0	994	int linkAction;
sl@0	995	if (objc == 5) {
sl@0	996	/* We have a '-linktype' argument */
sl@0	997	static CONST char *linkTypes[] = {
sl@0	998	"-symbolic", "-hard", NULL
sl@0	999	};
sl@0	1000	if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
sl@0	1001	"switch", 0, &linkAction) != TCL_OK) {
sl@0	1002	return TCL_ERROR;
sl@0	1003	}
sl@0	1004	if (linkAction == 0) {
sl@0	1005	linkAction = TCL_CREATE_SYMBOLIC_LINK;
sl@0	1006	} else {
sl@0	1007	linkAction = TCL_CREATE_HARD_LINK;
sl@0	1008	}
sl@0	1009	} else {
sl@0	1010	linkAction = TCL_CREATE_SYMBOLIC_LINK\|TCL_CREATE_HARD_LINK;
sl@0	1011	}
sl@0	1012	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
sl@0	1013	return TCL_ERROR;
sl@0	1014	}
sl@0	1015	/* Create link from source to target */
sl@0	1016	contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
sl@0	1017	if (contents == NULL) {
sl@0	1018	/*
sl@0	1019	* We handle two common error cases specially, and
sl@0	1020	* for all other errors, we use the standard posix
sl@0	1021	* error message.
sl@0	1022	*/
sl@0	1023	if (errno == EEXIST) {
sl@0	1024	Tcl_AppendResult(interp, "could not create new link \"",
sl@0	1025	Tcl_GetString(objv[index]),
sl@0	1026	"\": that path already exists", (char *) NULL);
sl@0	1027	} else if (errno == ENOENT) {
sl@0	1028	Tcl_AppendResult(interp, "could not create new link \"",
sl@0	1029	Tcl_GetString(objv[index]),
sl@0	1030	"\" since target \"",
sl@0	1031	Tcl_GetString(objv[index+1]),
sl@0	1032	"\" doesn't exist",
sl@0	1033	(char *) NULL);
sl@0	1034	} else {
sl@0	1035	Tcl_AppendResult(interp, "could not create new link \"",
sl@0	1036	Tcl_GetString(objv[index]), "\" pointing to \"",
sl@0	1037	Tcl_GetString(objv[index+1]), "\": ",
sl@0	1038	Tcl_PosixError(interp), (char *) NULL);
sl@0	1039	}
sl@0	1040	return TCL_ERROR;
sl@0	1041	}
sl@0	1042	} else {
sl@0	1043	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
sl@0	1044	return TCL_ERROR;
sl@0	1045	}
sl@0	1046	/* Read link */
sl@0	1047	contents = Tcl_FSLink(objv[index], NULL, 0);
sl@0	1048	if (contents == NULL) {
sl@0	1049	Tcl_AppendResult(interp, "could not read link \"",
sl@0	1050	Tcl_GetString(objv[index]), "\": ",
sl@0	1051	Tcl_PosixError(interp), (char *) NULL);
sl@0	1052	return TCL_ERROR;
sl@0	1053	}
sl@0	1054	}
sl@0	1055	Tcl_SetObjResult(interp, contents);
sl@0	1056	if (objc == 3) {
sl@0	1057	/*
sl@0	1058	* If we are reading a link, we need to free this
sl@0	1059	* result refCount. If we are creating a link, this
sl@0	1060	* will just be objv[index+1], and so we don't own it.
sl@0	1061	*/
sl@0	1062	Tcl_DecrRefCount(contents);
sl@0	1063	}
sl@0	1064	return TCL_OK;
sl@0	1065	}
sl@0	1066	case FCMD_LSTAT: {
sl@0	1067	char *varName;
sl@0	1068	Tcl_StatBuf buf;
sl@0	1069
sl@0	1070	if (objc != 4) {
sl@0	1071	Tcl_WrongNumArgs(interp, 2, objv, "name varName");
sl@0	1072	return TCL_ERROR;
sl@0	1073	}
sl@0	1074	if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
sl@0	1075	return TCL_ERROR;
sl@0	1076	}
sl@0	1077	varName = Tcl_GetString(objv[3]);
sl@0	1078	return StoreStatData(interp, varName, &buf);
sl@0	1079	}
sl@0	1080	case FCMD_MTIME: {
sl@0	1081	Tcl_StatBuf buf;
sl@0	1082	struct utimbuf tval;
sl@0	1083
sl@0	1084	if ((objc < 3) \|\| (objc > 4)) {
sl@0	1085	Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
sl@0	1086	return TCL_ERROR;
sl@0	1087	}
sl@0	1088	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	1089	return TCL_ERROR;
sl@0	1090	}
sl@0	1091	if (objc == 4) {
sl@0	1092	long newTime;
sl@0	1093
sl@0	1094	if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
sl@0	1095	return TCL_ERROR;
sl@0	1096	}
sl@0	1097	tval.actime = buf.st_atime;
sl@0	1098	tval.modtime = newTime;
sl@0	1099	if (Tcl_FSUtime(objv[2], &tval) != 0) {
sl@0	1100	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1101	"could not set modification time for file \"",
sl@0	1102	Tcl_GetString(objv[2]), "\": ",
sl@0	1103	Tcl_PosixError(interp), (char *) NULL);
sl@0	1104	return TCL_ERROR;
sl@0	1105	}
sl@0	1106	/*
sl@0	1107	* Do another stat to ensure that the we return the
sl@0	1108	* new recognized atime - hopefully the same as the
sl@0	1109	* one we sent in. However, fs's like FAT don't
sl@0	1110	* even know what atime is.
sl@0	1111	*/
sl@0	1112	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	1113	return TCL_ERROR;
sl@0	1114	}
sl@0	1115	}
sl@0	1116	Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
sl@0	1117	return TCL_OK;
sl@0	1118	}
sl@0	1119	case FCMD_MKDIR: {
sl@0	1120	if (objc < 3) {
sl@0	1121	Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
sl@0	1122	return TCL_ERROR;
sl@0	1123	}
sl@0	1124	return TclFileMakeDirsCmd(interp, objc, objv);
sl@0	1125	}
sl@0	1126	case FCMD_NATIVENAME: {
sl@0	1127	CONST char *fileName;
sl@0	1128	Tcl_DString ds;
sl@0	1129
sl@0	1130	if (objc != 3) {
sl@0	1131	goto only3Args;
sl@0	1132	}
sl@0	1133	fileName = Tcl_GetString(objv[2]);
sl@0	1134	fileName = Tcl_TranslateFileName(interp, fileName, &ds);
sl@0	1135	if (fileName == NULL) {
sl@0	1136	return TCL_ERROR;
sl@0	1137	}
sl@0	1138	Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
sl@0	1139	Tcl_DStringLength(&ds));
sl@0	1140	Tcl_DStringFree(&ds);
sl@0	1141	return TCL_OK;
sl@0	1142	}
sl@0	1143	case FCMD_NORMALIZE: {
sl@0	1144	Tcl_Obj *fileName;
sl@0	1145
sl@0	1146	if (objc != 3) {
sl@0	1147	Tcl_WrongNumArgs(interp, 2, objv, "filename");
sl@0	1148	return TCL_ERROR;
sl@0	1149	}
sl@0	1150
sl@0	1151	fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
sl@0	1152	if (fileName == NULL) {
sl@0	1153	return TCL_ERROR;
sl@0	1154	}
sl@0	1155	Tcl_SetObjResult(interp, fileName);
sl@0	1156	return TCL_OK;
sl@0	1157	}
sl@0	1158	case FCMD_OWNED: {
sl@0	1159	int value;
sl@0	1160	Tcl_StatBuf buf;
sl@0	1161
sl@0	1162	if (objc != 3) {
sl@0	1163	goto only3Args;
sl@0	1164	}
sl@0	1165	value = 0;
sl@0	1166	if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
sl@0	1167	/*
sl@0	1168	* For Windows and Macintosh, there are no user ids
sl@0	1169	* associated with a file, so we always return 1.
sl@0	1170	*/
sl@0	1171
sl@0	1172	#if (defined(__WIN32__) \|\| defined(MAC_TCL))
sl@0	1173	value = 1;
sl@0	1174	#else
sl@0	1175	value = (geteuid() == buf.st_uid);
sl@0	1176	#endif
sl@0	1177	}
sl@0	1178	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
sl@0	1179	return TCL_OK;
sl@0	1180	}
sl@0	1181	case FCMD_PATHTYPE: {
sl@0	1182	if (objc != 3) {
sl@0	1183	goto only3Args;
sl@0	1184	}
sl@0	1185	switch (Tcl_FSGetPathType(objv[2])) {
sl@0	1186	case TCL_PATH_ABSOLUTE:
sl@0	1187	Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
sl@0	1188	break;
sl@0	1189	case TCL_PATH_RELATIVE:
sl@0	1190	Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
sl@0	1191	break;
sl@0	1192	case TCL_PATH_VOLUME_RELATIVE:
sl@0	1193	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1194	"volumerelative", -1);
sl@0	1195	break;
sl@0	1196	}
sl@0	1197	return TCL_OK;
sl@0	1198	}
sl@0	1199	case FCMD_READABLE: {
sl@0	1200	if (objc != 3) {
sl@0	1201	goto only3Args;
sl@0	1202	}
sl@0	1203	return CheckAccess(interp, objv[2], R_OK);
sl@0	1204	}
sl@0	1205	case FCMD_READLINK: {
sl@0	1206	Tcl_Obj *contents;
sl@0	1207
sl@0	1208	if (objc != 3) {
sl@0	1209	goto only3Args;
sl@0	1210	}
sl@0	1211
sl@0	1212	if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
sl@0	1213	return TCL_ERROR;
sl@0	1214	}
sl@0	1215
sl@0	1216	contents = Tcl_FSLink(objv[2], NULL, 0);
sl@0	1217
sl@0	1218	if (contents == NULL) {
sl@0	1219	Tcl_AppendResult(interp, "could not readlink \"",
sl@0	1220	Tcl_GetString(objv[2]), "\": ",
sl@0	1221	Tcl_PosixError(interp), (char *) NULL);
sl@0	1222	return TCL_ERROR;
sl@0	1223	}
sl@0	1224	Tcl_SetObjResult(interp, contents);
sl@0	1225	Tcl_DecrRefCount(contents);
sl@0	1226	return TCL_OK;
sl@0	1227	}
sl@0	1228	case FCMD_RENAME: {
sl@0	1229	return TclFileRenameCmd(interp, objc, objv);
sl@0	1230	}
sl@0	1231	case FCMD_ROOTNAME: {
sl@0	1232	int length;
sl@0	1233	char fileName, extension;
sl@0	1234
sl@0	1235	if (objc != 3) {
sl@0	1236	goto only3Args;
sl@0	1237	}
sl@0	1238	fileName = Tcl_GetStringFromObj(objv[2], &length);
sl@0	1239	extension = TclGetExtension(fileName);
sl@0	1240	if (extension == NULL) {
sl@0	1241	Tcl_SetObjResult(interp, objv[2]);
sl@0	1242	} else {
sl@0	1243	Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
sl@0	1244	(int) (length - strlen(extension)));
sl@0	1245	}
sl@0	1246	return TCL_OK;
sl@0	1247	}
sl@0	1248	case FCMD_SEPARATOR: {
sl@0	1249	if ((objc < 2) \|\| (objc > 3)) {
sl@0	1250	Tcl_WrongNumArgs(interp, 2, objv, "?name?");
sl@0	1251	return TCL_ERROR;
sl@0	1252	}
sl@0	1253	if (objc == 2) {
sl@0	1254	char separator = NULL; / lint */
sl@0	1255	switch (tclPlatform) {
sl@0	1256	case TCL_PLATFORM_UNIX:
sl@0	1257	separator = "/";
sl@0	1258	break;
sl@0	1259	case TCL_PLATFORM_WINDOWS:
sl@0	1260	separator = "\\";
sl@0	1261	break;
sl@0	1262	case TCL_PLATFORM_MAC:
sl@0	1263	separator = ":";
sl@0	1264	break;
sl@0	1265	}
sl@0	1266	Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
sl@0	1267	} else {
sl@0	1268	Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
sl@0	1269	if (separatorObj != NULL) {
sl@0	1270	Tcl_SetObjResult(interp, separatorObj);
sl@0	1271	} else {
sl@0	1272	Tcl_SetObjResult(interp,
sl@0	1273	Tcl_NewStringObj("Unrecognised path",-1));
sl@0	1274	return TCL_ERROR;
sl@0	1275	}
sl@0	1276	}
sl@0	1277	return TCL_OK;
sl@0	1278	}
sl@0	1279	case FCMD_SIZE: {
sl@0	1280	Tcl_StatBuf buf;
sl@0	1281
sl@0	1282	if (objc != 3) {
sl@0	1283	goto only3Args;
sl@0	1284	}
sl@0	1285	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	1286	return TCL_ERROR;
sl@0	1287	}
sl@0	1288	Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
sl@0	1289	(Tcl_WideInt) buf.st_size);
sl@0	1290	return TCL_OK;
sl@0	1291	}
sl@0	1292	case FCMD_SPLIT: {
sl@0	1293	if (objc != 3) {
sl@0	1294	goto only3Args;
sl@0	1295	}
sl@0	1296	Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
sl@0	1297	return TCL_OK;
sl@0	1298	}
sl@0	1299	case FCMD_STAT: {
sl@0	1300	char *varName;
sl@0	1301	Tcl_StatBuf buf;
sl@0	1302
sl@0	1303	if (objc != 4) {
sl@0	1304	Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
sl@0	1305	return TCL_ERROR;
sl@0	1306	}
sl@0	1307	if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
sl@0	1308	return TCL_ERROR;
sl@0	1309	}
sl@0	1310	varName = Tcl_GetString(objv[3]);
sl@0	1311	return StoreStatData(interp, varName, &buf);
sl@0	1312	}
sl@0	1313	case FCMD_SYSTEM: {
sl@0	1314	Tcl_Obj* fsInfo;
sl@0	1315	if (objc != 3) {
sl@0	1316	goto only3Args;
sl@0	1317	}
sl@0	1318	fsInfo = Tcl_FSFileSystemInfo(objv[2]);
sl@0	1319	if (fsInfo != NULL) {
sl@0	1320	Tcl_SetObjResult(interp, fsInfo);
sl@0	1321	return TCL_OK;
sl@0	1322	} else {
sl@0	1323	Tcl_SetObjResult(interp,
sl@0	1324	Tcl_NewStringObj("Unrecognised path",-1));
sl@0	1325	return TCL_ERROR;
sl@0	1326	}
sl@0	1327	}
sl@0	1328	case FCMD_TAIL: {
sl@0	1329	int splitElements;
sl@0	1330	Tcl_Obj *splitPtr;
sl@0	1331
sl@0	1332	if (objc != 3) {
sl@0	1333	goto only3Args;
sl@0	1334	}
sl@0	1335	/*
sl@0	1336	* The behaviour we want here is slightly different to
sl@0	1337	* the standard Tcl_FSSplitPath in the handling of home
sl@0	1338	* directories; Tcl_FSSplitPath preserves the "~" while
sl@0	1339	* this code computes the actual full path name, if we
sl@0	1340	* had just a single component.
sl@0	1341	*/
sl@0	1342	splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
sl@0	1343	if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
sl@0	1344	Tcl_DecrRefCount(splitPtr);
sl@0	1345	splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
sl@0	1346	if (splitPtr == NULL) {
sl@0	1347	return TCL_ERROR;
sl@0	1348	}
sl@0	1349	splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
sl@0	1350	}
sl@0	1351
sl@0	1352	/*
sl@0	1353	* Return the last component, unless it is the only component,
sl@0	1354	* and it is the root of an absolute path.
sl@0	1355	*/
sl@0	1356
sl@0	1357	if (splitElements > 0) {
sl@0	1358	if ((splitElements > 1)
sl@0	1359	\|\| (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
sl@0	1360
sl@0	1361	Tcl_Obj *tail = NULL;
sl@0	1362	Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
sl@0	1363	Tcl_SetObjResult(interp, tail);
sl@0	1364	}
sl@0	1365	}
sl@0	1366	Tcl_DecrRefCount(splitPtr);
sl@0	1367	return TCL_OK;
sl@0	1368	}
sl@0	1369	case FCMD_TYPE: {
sl@0	1370	Tcl_StatBuf buf;
sl@0	1371
sl@0	1372	if (objc != 3) {
sl@0	1373	goto only3Args;
sl@0	1374	}
sl@0	1375	if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
sl@0	1376	return TCL_ERROR;
sl@0	1377	}
sl@0	1378	Tcl_SetStringObj(Tcl_GetObjResult(interp),
sl@0	1379	GetTypeFromMode((unsigned short) buf.st_mode), -1);
sl@0	1380	return TCL_OK;
sl@0	1381	}
sl@0	1382	case FCMD_VOLUMES: {
sl@0	1383	if (objc != 2) {
sl@0	1384	Tcl_WrongNumArgs(interp, 2, objv, NULL);
sl@0	1385	return TCL_ERROR;
sl@0	1386	}
sl@0	1387	Tcl_SetObjResult(interp, Tcl_FSListVolumes());
sl@0	1388	return TCL_OK;
sl@0	1389	}
sl@0	1390	case FCMD_WRITABLE: {
sl@0	1391	if (objc != 3) {
sl@0	1392	goto only3Args;
sl@0	1393	}
sl@0	1394	return CheckAccess(interp, objv[2], W_OK);
sl@0	1395	}
sl@0	1396	}
sl@0	1397
sl@0	1398	only3Args:
sl@0	1399	Tcl_WrongNumArgs(interp, 2, objv, "name");
sl@0	1400	return TCL_ERROR;
sl@0	1401	}
sl@0	1402
sl@0	1403	/*
sl@0	1404	*---------------------------------------------------------------------------
sl@0	1405	*
sl@0	1406	* CheckAccess --
sl@0	1407	*
sl@0	1408	* Utility procedure used by Tcl_FileObjCmd() to query file
sl@0	1409	* attributes available through the access() system call.
sl@0	1410	*
sl@0	1411	* Results:
sl@0	1412	* Always returns TCL_OK. Sets interp's result to boolean true or
sl@0	1413	* false depending on whether the file has the specified attribute.
sl@0	1414	*
sl@0	1415	* Side effects:
sl@0	1416	* None.
sl@0	1417	*
sl@0	1418	*---------------------------------------------------------------------------
sl@0	1419	*/
sl@0	1420
sl@0	1421	static int
sl@0	1422	CheckAccess(interp, objPtr, mode)
sl@0	1423	Tcl_Interp interp; / Interp for status return. Must not be
sl@0	1424	* NULL. */
sl@0	1425	Tcl_Obj objPtr; / Name of file to check. */
sl@0	1426	int mode; /* Attribute to check; passed as argument to
sl@0	1427	* access(). */
sl@0	1428	{
sl@0	1429	int value;
sl@0	1430
sl@0	1431	if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
sl@0	1432	value = 0;
sl@0	1433	} else {
sl@0	1434	value = (Tcl_FSAccess(objPtr, mode) == 0);
sl@0	1435	}
sl@0	1436	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
sl@0	1437
sl@0	1438	return TCL_OK;
sl@0	1439	}
sl@0	1440
sl@0	1441	/*
sl@0	1442	*---------------------------------------------------------------------------
sl@0	1443	*
sl@0	1444	* GetStatBuf --
sl@0	1445	*
sl@0	1446	* Utility procedure used by Tcl_FileObjCmd() to query file
sl@0	1447	* attributes available through the stat() or lstat() system call.
sl@0	1448	*
sl@0	1449	* Results:
sl@0	1450	* The return value is TCL_OK if the specified file exists and can
sl@0	1451	* be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an
sl@0	1452	* error message is left in interp's result. If TCL_OK is returned,
sl@0	1453	* *statPtr is filled with information about the specified file.
sl@0	1454	*
sl@0	1455	* Side effects:
sl@0	1456	* None.
sl@0	1457	*
sl@0	1458	*---------------------------------------------------------------------------
sl@0	1459	*/
sl@0	1460
sl@0	1461	static int
sl@0	1462	GetStatBuf(interp, objPtr, statProc, statPtr)
sl@0	1463	Tcl_Interp interp; / Interp for error return. May be NULL. */
sl@0	1464	Tcl_Obj objPtr; / Path name to examine. */
sl@0	1465	Tcl_FSStatProc statProc; / Either stat() or lstat() depending on
sl@0	1466	* desired behavior. */
sl@0	1467	Tcl_StatBuf statPtr; / Filled with info about file obtained by
sl@0	1468	* calling (statProc)(). /
sl@0	1469	{
sl@0	1470	int status;
sl@0	1471
sl@0	1472	if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
sl@0	1473	return TCL_ERROR;
sl@0	1474	}
sl@0	1475
sl@0	1476	status = (*statProc)(objPtr, statPtr);
sl@0	1477
sl@0	1478	if (status < 0) {
sl@0	1479	if (interp != NULL) {
sl@0	1480	Tcl_AppendResult(interp, "could not read \"",
sl@0	1481	Tcl_GetString(objPtr), "\": ",
sl@0	1482	Tcl_PosixError(interp), (char *) NULL);
sl@0	1483	}
sl@0	1484	return TCL_ERROR;
sl@0	1485	}
sl@0	1486	return TCL_OK;
sl@0	1487	}
sl@0	1488
sl@0	1489	/*
sl@0	1490	*----------------------------------------------------------------------
sl@0	1491	*
sl@0	1492	* StoreStatData --
sl@0	1493	*
sl@0	1494	* This is a utility procedure that breaks out the fields of a
sl@0	1495	* "stat" structure and stores them in textual form into the
sl@0	1496	* elements of an associative array.
sl@0	1497	*
sl@0	1498	* Results:
sl@0	1499	* Returns a standard Tcl return value. If an error occurs then
sl@0	1500	* a message is left in interp's result.
sl@0	1501	*
sl@0	1502	* Side effects:
sl@0	1503	* Elements of the associative array given by "varName" are modified.
sl@0	1504	*
sl@0	1505	*----------------------------------------------------------------------
sl@0	1506	*/
sl@0	1507
sl@0	1508	static int
sl@0	1509	StoreStatData(interp, varName, statPtr)
sl@0	1510	Tcl_Interp interp; / Interpreter for error reports. */
sl@0	1511	char varName; / Name of associative array variable
sl@0	1512	* in which to store stat results. */
sl@0	1513	Tcl_StatBuf statPtr; / Pointer to buffer containing
sl@0	1514	* stat data to store in varName. */
sl@0	1515	{
sl@0	1516	Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
sl@0	1517	Tcl_Obj *field = Tcl_NewObj();
sl@0	1518	Tcl_Obj *value;
sl@0	1519	register unsigned short mode;
sl@0	1520
sl@0	1521	/*
sl@0	1522	* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
sl@0	1523	*/
sl@0	1524	#define STORE_ARY(fieldName, object) \
sl@0	1525	Tcl_SetStringObj(field, (fieldName), -1); \
sl@0	1526	value = (object); \
sl@0	1527	if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
sl@0	1528	Tcl_DecrRefCount(var); \
sl@0	1529	Tcl_DecrRefCount(field); \
sl@0	1530	Tcl_DecrRefCount(value); \
sl@0	1531	return TCL_ERROR; \
sl@0	1532	}
sl@0	1533
sl@0	1534	Tcl_IncrRefCount(var);
sl@0	1535	Tcl_IncrRefCount(field);
sl@0	1536	STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
sl@0	1537	/*
sl@0	1538	* Watch out porters; the inode is meant to be an unsigned value,
sl@0	1539	* so the cast might fail when there isn't a real arithmentic 'long
sl@0	1540	* long' type...
sl@0	1541	*/
sl@0	1542	STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
sl@0	1543	STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
sl@0	1544	STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
sl@0	1545	STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
sl@0	1546	STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
sl@0	1547	#ifdef HAVE_ST_BLOCKS
sl@0	1548	STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
sl@0	1549	#endif
sl@0	1550	STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
sl@0	1551	STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
sl@0	1552	STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
sl@0	1553	mode = (unsigned short) statPtr->st_mode;
sl@0	1554	STORE_ARY("mode", Tcl_NewIntObj(mode));
sl@0	1555	STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
sl@0	1556	#undef STORE_ARY
sl@0	1557	Tcl_DecrRefCount(var);
sl@0	1558	Tcl_DecrRefCount(field);
sl@0	1559	return TCL_OK;
sl@0	1560	}
sl@0	1561
sl@0	1562	/*
sl@0	1563	*----------------------------------------------------------------------
sl@0	1564	*
sl@0	1565	* GetTypeFromMode --
sl@0	1566	*
sl@0	1567	* Given a mode word, returns a string identifying the type of a
sl@0	1568	* file.
sl@0	1569	*
sl@0	1570	* Results:
sl@0	1571	* A static text string giving the file type from mode.
sl@0	1572	*
sl@0	1573	* Side effects:
sl@0	1574	* None.
sl@0	1575	*
sl@0	1576	*----------------------------------------------------------------------
sl@0	1577	*/
sl@0	1578
sl@0	1579	static char *
sl@0	1580	GetTypeFromMode(mode)
sl@0	1581	int mode;
sl@0	1582	{
sl@0	1583	if (S_ISREG(mode)) {
sl@0	1584	return "file";
sl@0	1585	} else if (S_ISDIR(mode)) {
sl@0	1586	return "directory";
sl@0	1587	} else if (S_ISCHR(mode)) {
sl@0	1588	return "characterSpecial";
sl@0	1589	} else if (S_ISBLK(mode)) {
sl@0	1590	return "blockSpecial";
sl@0	1591	} else if (S_ISFIFO(mode)) {
sl@0	1592	return "fifo";
sl@0	1593	#ifdef S_ISLNK
sl@0	1594	} else if (S_ISLNK(mode)) {
sl@0	1595	return "link";
sl@0	1596	#endif
sl@0	1597	#ifdef S_ISSOCK
sl@0	1598	} else if (S_ISSOCK(mode)) {
sl@0	1599	return "socket";
sl@0	1600	#endif
sl@0	1601	}
sl@0	1602	return "unknown";
sl@0	1603	}
sl@0	1604
sl@0	1605	/*
sl@0	1606	*----------------------------------------------------------------------
sl@0	1607	*
sl@0	1608	* Tcl_ForObjCmd --
sl@0	1609	*
sl@0	1610	* This procedure is invoked to process the "for" Tcl command.
sl@0	1611	* See the user documentation for details on what it does.
sl@0	1612	*
sl@0	1613	* With the bytecode compiler, this procedure is only called when
sl@0	1614	* a command name is computed at runtime, and is "for" or the name
sl@0	1615	* to which "for" was renamed: e.g.,
sl@0	1616	* "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
sl@0	1617	*
sl@0	1618	* Results:
sl@0	1619	* A standard Tcl result.
sl@0	1620	*
sl@0	1621	* Side effects:
sl@0	1622	* See the user documentation.
sl@0	1623	*
sl@0	1624	*----------------------------------------------------------------------
sl@0	1625	*/
sl@0	1626
sl@0	1627	/* ARGSUSED */
sl@0	1628	int
sl@0	1629	Tcl_ForObjCmd(dummy, interp, objc, objv)
sl@0	1630	ClientData dummy; /* Not used. */
sl@0	1631	Tcl_Interp interp; / Current interpreter. */
sl@0	1632	int objc; /* Number of arguments. */
sl@0	1633	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1634	{
sl@0	1635	int result, value;
sl@0	1636	#ifdef TCL_TIP280
sl@0	1637	Interp* iPtr = (Interp*) interp;
sl@0	1638	#endif
sl@0	1639
sl@0	1640	if (objc != 5) {
sl@0	1641	Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
sl@0	1642	return TCL_ERROR;
sl@0	1643	}
sl@0	1644
sl@0	1645	#ifndef TCL_TIP280
sl@0	1646	result = Tcl_EvalObjEx(interp, objv[1], 0);
sl@0	1647	#else
sl@0	1648	/* TIP #280. Make invoking context available to initial script */
sl@0	1649	result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
sl@0	1650	#endif
sl@0	1651	if (result != TCL_OK) {
sl@0	1652	if (result == TCL_ERROR) {
sl@0	1653	Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
sl@0	1654	}
sl@0	1655	return result;
sl@0	1656	}
sl@0	1657	while (1) {
sl@0	1658	/*
sl@0	1659	* We need to reset the result before passing it off to
sl@0	1660	* Tcl_ExprBooleanObj. Otherwise, any error message will be appended
sl@0	1661	* to the result of the last evaluation.
sl@0	1662	*/
sl@0	1663
sl@0	1664	Tcl_ResetResult(interp);
sl@0	1665	result = Tcl_ExprBooleanObj(interp, objv[2], &value);
sl@0	1666	if (result != TCL_OK) {
sl@0	1667	return result;
sl@0	1668	}
sl@0	1669	if (!value) {
sl@0	1670	break;
sl@0	1671	}
sl@0	1672	#ifndef TCL_TIP280
sl@0	1673	result = Tcl_EvalObjEx(interp, objv[4], 0);
sl@0	1674	#else
sl@0	1675	/* TIP #280. Make invoking context available to loop body */
sl@0	1676	result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4);
sl@0	1677	#endif
sl@0	1678	if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
sl@0	1679	if (result == TCL_ERROR) {
sl@0	1680	char msg[32 + TCL_INTEGER_SPACE];
sl@0	1681
sl@0	1682	sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
sl@0	1683	Tcl_AddErrorInfo(interp, msg);
sl@0	1684	}
sl@0	1685	break;
sl@0	1686	}
sl@0	1687	#ifndef TCL_TIP280
sl@0	1688	result = Tcl_EvalObjEx(interp, objv[3], 0);
sl@0	1689	#else
sl@0	1690	/* TIP #280. Make invoking context available to next script */
sl@0	1691	result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
sl@0	1692	#endif
sl@0	1693	if (result == TCL_BREAK) {
sl@0	1694	break;
sl@0	1695	} else if (result != TCL_OK) {
sl@0	1696	if (result == TCL_ERROR) {
sl@0	1697	Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
sl@0	1698	}
sl@0	1699	return result;
sl@0	1700	}
sl@0	1701	}
sl@0	1702	if (result == TCL_BREAK) {
sl@0	1703	result = TCL_OK;
sl@0	1704	}
sl@0	1705	if (result == TCL_OK) {
sl@0	1706	Tcl_ResetResult(interp);
sl@0	1707	}
sl@0	1708	return result;
sl@0	1709	}
sl@0	1710
sl@0	1711	/*
sl@0	1712	*----------------------------------------------------------------------
sl@0	1713	*
sl@0	1714	* Tcl_ForeachObjCmd --
sl@0	1715	*
sl@0	1716	* This object-based procedure is invoked to process the "foreach" Tcl
sl@0	1717	* command. See the user documentation for details on what it does.
sl@0	1718	*
sl@0	1719	* Results:
sl@0	1720	* A standard Tcl object result.
sl@0	1721	*
sl@0	1722	* Side effects:
sl@0	1723	* See the user documentation.
sl@0	1724	*
sl@0	1725	*----------------------------------------------------------------------
sl@0	1726	*/
sl@0	1727
sl@0	1728	/* ARGSUSED */
sl@0	1729	int
sl@0	1730	Tcl_ForeachObjCmd(dummy, interp, objc, objv)
sl@0	1731	ClientData dummy; /* Not used. */
sl@0	1732	Tcl_Interp interp; / Current interpreter. */
sl@0	1733	int objc; /* Number of arguments. */
sl@0	1734	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1735	{
sl@0	1736	int result = TCL_OK;
sl@0	1737	int i; /* i selects a value list */
sl@0	1738	int j, maxj; /* Number of loop iterations */
sl@0	1739	int v; /* v selects a loop variable */
sl@0	1740	int numLists; /* Count of value lists */
sl@0	1741	Tcl_Obj *bodyPtr;
sl@0	1742
sl@0	1743	/*
sl@0	1744	* We copy the argument object pointers into a local array to avoid
sl@0	1745	* the problem that "objv" might become invalid. It is a pointer into
sl@0	1746	* the evaluation stack and that stack might be grown and reallocated
sl@0	1747	* if the loop body requires a large amount of stack space.
sl@0	1748	*/
sl@0	1749
sl@0	1750	#define NUM_ARGS 9
sl@0	1751	Tcl_Obj *(argObjStorage[NUM_ARGS]);
sl@0	1752	Tcl_Obj **argObjv = argObjStorage;
sl@0	1753
sl@0	1754	#define STATIC_LIST_SIZE 4
sl@0	1755	int indexArray[STATIC_LIST_SIZE];
sl@0	1756	int varcListArray[STATIC_LIST_SIZE];
sl@0	1757	Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
sl@0	1758	int argcListArray[STATIC_LIST_SIZE];
sl@0	1759	Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
sl@0	1760
sl@0	1761	int index = indexArray; / Array of value list indices */
sl@0	1762	int varcList = varcListArray; / # loop variables per list */
sl@0	1763	Tcl_Obj **varvList = varvListArray; / Array of var name lists */
sl@0	1764	int argcList = argcListArray; / Array of value list sizes */
sl@0	1765	Tcl_Obj **argvList = argvListArray; / Array of value lists */
sl@0	1766	#ifdef TCL_TIP280
sl@0	1767	Interp* iPtr = (Interp*) interp;
sl@0	1768	#endif
sl@0	1769
sl@0	1770	if (objc < 4 \|\| (objc%2 != 0)) {
sl@0	1771	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1772	"varList list ?varList list ...? command");
sl@0	1773	return TCL_ERROR;
sl@0	1774	}
sl@0	1775
sl@0	1776	/*
sl@0	1777	* Create the object argument array "argObjv". Make sure argObjv is
sl@0	1778	* large enough to hold the objc arguments.
sl@0	1779	*/
sl@0	1780
sl@0	1781	if (objc > NUM_ARGS) {
sl@0	1782	argObjv = (Tcl_Obj *) ckalloc(objc sizeof(Tcl_Obj *));
sl@0	1783	}
sl@0	1784	for (i = 0; i < objc; i++) {
sl@0	1785	argObjv[i] = objv[i];
sl@0	1786	}
sl@0	1787
sl@0	1788	/*
sl@0	1789	* Manage numList parallel value lists.
sl@0	1790	* argvList[i] is a value list counted by argcList[i]
sl@0	1791	* varvList[i] is the list of variables associated with the value list
sl@0	1792	* varcList[i] is the number of variables associated with the value list
sl@0	1793	* index[i] is the current pointer into the value list argvList[i]
sl@0	1794	*/
sl@0	1795
sl@0	1796	numLists = (objc-2)/2;
sl@0	1797	if (numLists > STATIC_LIST_SIZE) {
sl@0	1798	index = (int ) ckalloc(numLists sizeof(int));
sl@0	1799	varcList = (int ) ckalloc(numLists sizeof(int));
sl@0	1800	varvList = (Tcl_Obj **) ckalloc(numLists sizeof(Tcl_Obj **));
sl@0	1801	argcList = (int ) ckalloc(numLists sizeof(int));
sl@0	1802	argvList = (Tcl_Obj **) ckalloc(numLists sizeof(Tcl_Obj **));
sl@0	1803	}
sl@0	1804	for (i = 0; i < numLists; i++) {
sl@0	1805	index[i] = 0;
sl@0	1806	varcList[i] = 0;
sl@0	1807	varvList[i] = (Tcl_Obj **) NULL;
sl@0	1808	argcList[i] = 0;
sl@0	1809	argvList[i] = (Tcl_Obj **) NULL;
sl@0	1810	}
sl@0	1811
sl@0	1812	/*
sl@0	1813	* Break up the value lists and variable lists into elements
sl@0	1814	*/
sl@0	1815
sl@0	1816	maxj = 0;
sl@0	1817	for (i = 0; i < numLists; i++) {
sl@0	1818	result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
sl@0	1819	&varcList[i], &varvList[i]);
sl@0	1820	if (result != TCL_OK) {
sl@0	1821	goto done;
sl@0	1822	}
sl@0	1823	if (varcList[i] < 1) {
sl@0	1824	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1825	"foreach varlist is empty", -1);
sl@0	1826	result = TCL_ERROR;
sl@0	1827	goto done;
sl@0	1828	}
sl@0	1829
sl@0	1830	result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
sl@0	1831	&argcList[i], &argvList[i]);
sl@0	1832	if (result != TCL_OK) {
sl@0	1833	goto done;
sl@0	1834	}
sl@0	1835
sl@0	1836	j = argcList[i] / varcList[i];
sl@0	1837	if ((argcList[i] % varcList[i]) != 0) {
sl@0	1838	j++;
sl@0	1839	}
sl@0	1840	if (j > maxj) {
sl@0	1841	maxj = j;
sl@0	1842	}
sl@0	1843	}
sl@0	1844
sl@0	1845	/*
sl@0	1846	* Iterate maxj times through the lists in parallel
sl@0	1847	* If some value lists run out of values, set loop vars to ""
sl@0	1848	*/
sl@0	1849
sl@0	1850	bodyPtr = argObjv[objc-1];
sl@0	1851	for (j = 0; j < maxj; j++) {
sl@0	1852	for (i = 0; i < numLists; i++) {
sl@0	1853	/*
sl@0	1854	* Refetch the list members; we assume that the sizes are
sl@0	1855	* the same, but the array of elements might be different
sl@0	1856	* if the internal rep of the objects has been lost and
sl@0	1857	* recreated (it is too difficult to accurately tell when
sl@0	1858	* this happens, which can lead to some wierd crashes,
sl@0	1859	* like Bug #494348...)
sl@0	1860	*/
sl@0	1861
sl@0	1862	result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
sl@0	1863	&varcList[i], &varvList[i]);
sl@0	1864	if (result != TCL_OK) {
sl@0	1865	panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
sl@0	1866	}
sl@0	1867	result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
sl@0	1868	&argcList[i], &argvList[i]);
sl@0	1869	if (result != TCL_OK) {
sl@0	1870	panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
sl@0	1871	}
sl@0	1872
sl@0	1873	for (v = 0; v < varcList[i]; v++) {
sl@0	1874	int k = index[i]++;
sl@0	1875	Tcl_Obj valuePtr, varValuePtr;
sl@0	1876
sl@0	1877	if (k < argcList[i]) {
sl@0	1878	valuePtr = argvList[i][k];
sl@0	1879	} else {
sl@0	1880	valuePtr = Tcl_NewObj(); /* empty string */
sl@0	1881	}
sl@0	1882	Tcl_IncrRefCount(valuePtr);
sl@0	1883	varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
sl@0	1884	NULL, valuePtr, 0);
sl@0	1885	Tcl_DecrRefCount(valuePtr);
sl@0	1886	if (varValuePtr == NULL) {
sl@0	1887	Tcl_ResetResult(interp);
sl@0	1888	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	1889	"couldn't set loop variable: \"",
sl@0	1890	Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
sl@0	1891	result = TCL_ERROR;
sl@0	1892	goto done;
sl@0	1893	}
sl@0	1894
sl@0	1895	}
sl@0	1896	}
sl@0	1897
sl@0	1898	#ifndef TCL_TIP280
sl@0	1899	result = Tcl_EvalObjEx(interp, bodyPtr, 0);
sl@0	1900	#else
sl@0	1901	/* TIP #280. Make invoking context available to loop body */
sl@0	1902	result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1);
sl@0	1903	#endif
sl@0	1904	if (result != TCL_OK) {
sl@0	1905	if (result == TCL_CONTINUE) {
sl@0	1906	result = TCL_OK;
sl@0	1907	} else if (result == TCL_BREAK) {
sl@0	1908	result = TCL_OK;
sl@0	1909	break;
sl@0	1910	} else if (result == TCL_ERROR) {
sl@0	1911	char msg[32 + TCL_INTEGER_SPACE];
sl@0	1912
sl@0	1913	sprintf(msg, "\n (\"foreach\" body line %d)",
sl@0	1914	interp->errorLine);
sl@0	1915	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	1916	break;
sl@0	1917	} else {
sl@0	1918	break;
sl@0	1919	}
sl@0	1920	}
sl@0	1921	}
sl@0	1922	if (result == TCL_OK) {
sl@0	1923	Tcl_ResetResult(interp);
sl@0	1924	}
sl@0	1925
sl@0	1926	done:
sl@0	1927	if (numLists > STATIC_LIST_SIZE) {
sl@0	1928	ckfree((char *) index);
sl@0	1929	ckfree((char *) varcList);
sl@0	1930	ckfree((char *) argcList);
sl@0	1931	ckfree((char *) varvList);
sl@0	1932	ckfree((char *) argvList);
sl@0	1933	}
sl@0	1934	if (argObjv != argObjStorage) {
sl@0	1935	ckfree((char *) argObjv);
sl@0	1936	}
sl@0	1937	return result;
sl@0	1938	#undef STATIC_LIST_SIZE
sl@0	1939	#undef NUM_ARGS
sl@0	1940	}
sl@0	1941
sl@0	1942	/*
sl@0	1943	*----------------------------------------------------------------------
sl@0	1944	*
sl@0	1945	* Tcl_FormatObjCmd --
sl@0	1946	*
sl@0	1947	* This procedure is invoked to process the "format" Tcl command.
sl@0	1948	* See the user documentation for details on what it does.
sl@0	1949	*
sl@0	1950	* Results:
sl@0	1951	* A standard Tcl result.
sl@0	1952	*
sl@0	1953	* Side effects:
sl@0	1954	* See the user documentation.
sl@0	1955	*
sl@0	1956	*----------------------------------------------------------------------
sl@0	1957	*/
sl@0	1958
sl@0	1959	/* ARGSUSED */
sl@0	1960	int
sl@0	1961	Tcl_FormatObjCmd(dummy, interp, objc, objv)
sl@0	1962	ClientData dummy; /* Not used. */
sl@0	1963	Tcl_Interp interp; / Current interpreter. */
sl@0	1964	int objc; /* Number of arguments. */
sl@0	1965	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1966	{
sl@0	1967	char format; / Used to read characters from the format
sl@0	1968	* string. */
sl@0	1969	int formatLen; /* The length of the format string */
sl@0	1970	char endPtr; / Points to the last char in format array */
sl@0	1971	char newFormat[43]; /* A new format specifier is generated here. */
sl@0	1972	int width; /* Field width from field specifier, or 0 if
sl@0	1973	* no width given. */
sl@0	1974	int precision; /* Field precision from field specifier, or 0
sl@0	1975	* if no precision given. */
sl@0	1976	int size; /* Number of bytes needed for result of
sl@0	1977	* conversion, based on type of conversion
sl@0	1978	* ("e", "s", etc.), width, and precision. */
sl@0	1979	long intValue; /* Used to hold value to pass to sprintf, if
sl@0	1980	* it's a one-word integer or char value */
sl@0	1981	char ptrValue = NULL; / Used to hold value to pass to sprintf, if
sl@0	1982	* it's a one-word value. */
sl@0	1983	double doubleValue; /* Used to hold value to pass to sprintf if
sl@0	1984	* it's a double value. */
sl@0	1985	Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
sl@0	1986	* it's a 'long long' value. */
sl@0	1987	int whichValue; /* Indicates which of intValue, ptrValue,
sl@0	1988	* or doubleValue has the value to pass to
sl@0	1989	* sprintf, according to the following
sl@0	1990	* definitions: */
sl@0	1991	# define INT_VALUE 0
sl@0	1992	# define CHAR_VALUE 1
sl@0	1993	# define PTR_VALUE 2
sl@0	1994	# define DOUBLE_VALUE 3
sl@0	1995	# define STRING_VALUE 4
sl@0	1996	# define WIDE_VALUE 5
sl@0	1997	# define MAX_FLOAT_SIZE 320
sl@0	1998
sl@0	1999	Tcl_Obj resultPtr; / Where result is stored finally. */
sl@0	2000	char staticBuf[MAX_FLOAT_SIZE + 1];
sl@0	2001	/* A static buffer to copy the format results
sl@0	2002	* into */
sl@0	2003	char dst = staticBuf; / The buffer that sprintf writes into each
sl@0	2004	* time the format processes a specifier */
sl@0	2005	int dstSize = MAX_FLOAT_SIZE;
sl@0	2006	/* The size of the dst buffer */
sl@0	2007	int noPercent; /* Special case for speed: indicates there's
sl@0	2008	* no field specifier, just a string to copy.*/
sl@0	2009	int objIndex; /* Index of argument to substitute next. */
sl@0	2010	int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
sl@0	2011	* specifier has been seen. */
sl@0	2012	int gotSequential = 0; /* Non-zero means that a regular sequential
sl@0	2013	* (non-XPG3) conversion specifier has been
sl@0	2014	* seen. */
sl@0	2015	int useShort; /* Value to be printed is short (half word). */
sl@0	2016	char end; / Used to locate end of numerical fields. */
sl@0	2017	int stringLen = 0; /* Length of string in characters rather
sl@0	2018	* than bytes. Used for %s substitution. */
sl@0	2019	int gotMinus; /* Non-zero indicates that a minus flag has
sl@0	2020	* been seen in the current field. */
sl@0	2021	int gotPrecision; /* Non-zero indicates that a precision has
sl@0	2022	* been set for the current field. */
sl@0	2023	int gotZero; /* Non-zero indicates that a zero flag has
sl@0	2024	* been seen in the current field. */
sl@0	2025	int useWide; /* Value to be printed is Tcl_WideInt. */
sl@0	2026
sl@0	2027	/*
sl@0	2028	* This procedure is a bit nasty. The goal is to use sprintf to
sl@0	2029	* do most of the dirty work. There are several problems:
sl@0	2030	* 1. this procedure can't trust its arguments.
sl@0	2031	* 2. we must be able to provide a large enough result area to hold
sl@0	2032	* whatever's generated. This is hard to estimate.
sl@0	2033	* 3. there's no way to move the arguments from objv to the call
sl@0	2034	* to sprintf in a reasonable way. This is particularly nasty
sl@0	2035	* because some of the arguments may be two-word values (doubles
sl@0	2036	* and wide-ints).
sl@0	2037	* So, what happens here is to scan the format string one % group
sl@0	2038	* at a time, making many individual calls to sprintf.
sl@0	2039	*/
sl@0	2040
sl@0	2041	if (objc < 2) {
sl@0	2042	Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
sl@0	2043	return TCL_ERROR;
sl@0	2044	}
sl@0	2045
sl@0	2046	format = Tcl_GetStringFromObj(objv[1], &formatLen);
sl@0	2047	endPtr = format + formatLen;
sl@0	2048	resultPtr = Tcl_NewObj();
sl@0	2049	objIndex = 2;
sl@0	2050
sl@0	2051	while (format < endPtr) {
sl@0	2052	register char *newPtr = newFormat;
sl@0	2053
sl@0	2054	width = precision = noPercent = useShort = 0;
sl@0	2055	gotZero = gotMinus = gotPrecision = 0;
sl@0	2056	useWide = 0;
sl@0	2057	whichValue = PTR_VALUE;
sl@0	2058
sl@0	2059	/*
sl@0	2060	* Get rid of any characters before the next field specifier.
sl@0	2061	*/
sl@0	2062	if (*format != '%') {
sl@0	2063	ptrValue = format;
sl@0	2064	while ((*format != '%') && (format < endPtr)) {
sl@0	2065	format++;
sl@0	2066	}
sl@0	2067	size = format - ptrValue;
sl@0	2068	noPercent = 1;
sl@0	2069	goto doField;
sl@0	2070	}
sl@0	2071
sl@0	2072	if (format[1] == '%') {
sl@0	2073	ptrValue = format;
sl@0	2074	size = 1;
sl@0	2075	noPercent = 1;
sl@0	2076	format += 2;
sl@0	2077	goto doField;
sl@0	2078	}
sl@0	2079
sl@0	2080	/*
sl@0	2081	* Parse off a field specifier, compute how many characters
sl@0	2082	* will be needed to store the result, and substitute for
sl@0	2083	* "*" size specifiers.
sl@0	2084	*/
sl@0	2085	*newPtr = '%';
sl@0	2086	newPtr++;
sl@0	2087	format++;
sl@0	2088	if (isdigit(UCHAR(format))) { / INTL: Tcl source. */
sl@0	2089	int tmp;
sl@0	2090
sl@0	2091	/*
sl@0	2092	* Check for an XPG3-style %n$ specification. Note: there
sl@0	2093	* must not be a mixture of XPG3 specs and non-XPG3 specs
sl@0	2094	* in the same format string.
sl@0	2095	*/
sl@0	2096
sl@0	2097	tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */
sl@0	2098	if (*end != '$') {
sl@0	2099	goto notXpg;
sl@0	2100	}
sl@0	2101	format = end+1;
sl@0	2102	gotXpg = 1;
sl@0	2103	if (gotSequential) {
sl@0	2104	goto mixedXPG;
sl@0	2105	}
sl@0	2106	objIndex = tmp+1;
sl@0	2107	if ((objIndex < 2) \|\| (objIndex >= objc)) {
sl@0	2108	goto badIndex;
sl@0	2109	}
sl@0	2110	goto xpgCheckDone;
sl@0	2111	}
sl@0	2112
sl@0	2113	notXpg:
sl@0	2114	gotSequential = 1;
sl@0	2115	if (gotXpg) {
sl@0	2116	goto mixedXPG;
sl@0	2117	}
sl@0	2118
sl@0	2119	xpgCheckDone:
sl@0	2120	while ((format == '-') \|\| (format == '#') \|\| (*format == '0')
sl@0	2121	\|\| (format == ' ') \|\| (format == '+')) {
sl@0	2122	if (*format == '-') {
sl@0	2123	gotMinus = 1;
sl@0	2124	}
sl@0	2125	if (*format == '0') {
sl@0	2126	/*
sl@0	2127	* This will be handled by sprintf for numbers, but we
sl@0	2128	* need to do the char/string ones ourselves
sl@0	2129	*/
sl@0	2130	gotZero = 1;
sl@0	2131	}
sl@0	2132	newPtr = format;
sl@0	2133	newPtr++;
sl@0	2134	format++;
sl@0	2135	}
sl@0	2136	if (isdigit(UCHAR(format))) { / INTL: Tcl source. */
sl@0	2137	width = strtoul(format, &end, 10); /* INTL: Tcl source. */
sl@0	2138	format = end;
sl@0	2139	} else if (format == '') {
sl@0	2140	if (objIndex >= objc) {
sl@0	2141	goto badIndex;
sl@0	2142	}
sl@0	2143	if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
sl@0	2144	objv[objIndex], &width) != TCL_OK) {
sl@0	2145	goto fmtError;
sl@0	2146	}
sl@0	2147	if (width < 0) {
sl@0	2148	width = -width;
sl@0	2149	*newPtr = '-';
sl@0	2150	gotMinus = 1;
sl@0	2151	newPtr++;
sl@0	2152	}
sl@0	2153	objIndex++;
sl@0	2154	format++;
sl@0	2155	}
sl@0	2156	if (width > 100000) {
sl@0	2157	/*
sl@0	2158	* Don't allow arbitrarily large widths: could cause core
sl@0	2159	* dump when we try to allocate a zillion bytes of memory
sl@0	2160	* below.
sl@0	2161	*/
sl@0	2162
sl@0	2163	width = 100000;
sl@0	2164	} else if (width < 0) {
sl@0	2165	width = 0;
sl@0	2166	}
sl@0	2167	if (width != 0) {
sl@0	2168	TclFormatInt(newPtr, width); /* INTL: printf format. */
sl@0	2169	while (*newPtr != 0) {
sl@0	2170	newPtr++;
sl@0	2171	}
sl@0	2172	}
sl@0	2173	if (*format == '.') {
sl@0	2174	*newPtr = '.';
sl@0	2175	newPtr++;
sl@0	2176	format++;
sl@0	2177	gotPrecision = 1;
sl@0	2178	}
sl@0	2179	if (isdigit(UCHAR(format))) { / INTL: Tcl source. */
sl@0	2180	precision = strtoul(format, &end, 10); /* INTL: "C" locale. */
sl@0	2181	format = end;
sl@0	2182	} else if (format == '') {
sl@0	2183	if (objIndex >= objc) {
sl@0	2184	goto badIndex;
sl@0	2185	}
sl@0	2186	if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
sl@0	2187	objv[objIndex], &precision) != TCL_OK) {
sl@0	2188	goto fmtError;
sl@0	2189	}
sl@0	2190	objIndex++;
sl@0	2191	format++;
sl@0	2192	}
sl@0	2193	if (gotPrecision) {
sl@0	2194	TclFormatInt(newPtr, precision); /* INTL: printf format. */
sl@0	2195	while (*newPtr != 0) {
sl@0	2196	newPtr++;
sl@0	2197	}
sl@0	2198	}
sl@0	2199	if (*format == 'l') {
sl@0	2200	useWide = 1;
sl@0	2201	/*
sl@0	2202	* Only add a 'll' modifier for integer values as it makes
sl@0	2203	* some libc's go into spasm otherwise. [Bug #702622]
sl@0	2204	*/
sl@0	2205	switch (format[1]) {
sl@0	2206	case 'i':
sl@0	2207	case 'd':
sl@0	2208	case 'o':
sl@0	2209	case 'u':
sl@0	2210	case 'x':
sl@0	2211	case 'X':
sl@0	2212	strcpy(newPtr, TCL_LL_MODIFIER);
sl@0	2213	newPtr += TCL_LL_MODIFIER_SIZE;
sl@0	2214	}
sl@0	2215	format++;
sl@0	2216	} else if (*format == 'h') {
sl@0	2217	useShort = 1;
sl@0	2218	*newPtr = 'h';
sl@0	2219	newPtr++;
sl@0	2220	format++;
sl@0	2221	}
sl@0	2222	newPtr = format;
sl@0	2223	newPtr++;
sl@0	2224	*newPtr = 0;
sl@0	2225	if (objIndex >= objc) {
sl@0	2226	goto badIndex;
sl@0	2227	}
sl@0	2228	switch (*format) {
sl@0	2229	case 'i':
sl@0	2230	newPtr[-1] = 'd';
sl@0	2231	case 'd':
sl@0	2232	case 'o':
sl@0	2233	case 'u':
sl@0	2234	case 'x':
sl@0	2235	case 'X':
sl@0	2236	if (useWide) {
sl@0	2237	if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
sl@0	2238	objv[objIndex], &wideValue) != TCL_OK) {
sl@0	2239	goto fmtError;
sl@0	2240	}
sl@0	2241	whichValue = WIDE_VALUE;
sl@0	2242	size = 40 + precision;
sl@0	2243	break;
sl@0	2244	}
sl@0	2245	if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
sl@0	2246	objv[objIndex], &intValue) != TCL_OK) {
sl@0	2247	if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
sl@0	2248	objv[objIndex], &wideValue) != TCL_OK) {
sl@0	2249	goto fmtError;
sl@0	2250	}
sl@0	2251	intValue = Tcl_WideAsLong(wideValue);
sl@0	2252	}
sl@0	2253
sl@0	2254	#if (LONG_MAX > INT_MAX)
sl@0	2255	if (!useShort) {
sl@0	2256	/*
sl@0	2257	* Add the 'l' for long format type because we are on an
sl@0	2258	* LP64 archtecture and we are really going to pass a long
sl@0	2259	* argument to sprintf.
sl@0	2260	*
sl@0	2261	* Do not add this if we're going to pass in a short (i.e.
sl@0	2262	* if we've got an 'h' modifier already in the string); some
sl@0	2263	* libc implementations of sprintf() do not like it at all.
sl@0	2264	* [Bug 1154163]
sl@0	2265	*/
sl@0	2266	newPtr++;
sl@0	2267	*newPtr = 0;
sl@0	2268	newPtr[-1] = newPtr[-2];
sl@0	2269	newPtr[-2] = 'l';
sl@0	2270	}
sl@0	2271	#endif /* LONG_MAX > INT_MAX */
sl@0	2272	whichValue = INT_VALUE;
sl@0	2273	size = 40 + precision;
sl@0	2274	break;
sl@0	2275	case 's':
sl@0	2276	/*
sl@0	2277	* Compute the length of the string in characters and add
sl@0	2278	* any additional space required by the field width. All
sl@0	2279	* of the extra characters will be spaces, so one byte per
sl@0	2280	* character is adequate.
sl@0	2281	*/
sl@0	2282
sl@0	2283	whichValue = STRING_VALUE;
sl@0	2284	ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
sl@0	2285	stringLen = Tcl_NumUtfChars(ptrValue, size);
sl@0	2286	if (gotPrecision && (precision < stringLen)) {
sl@0	2287	stringLen = precision;
sl@0	2288	}
sl@0	2289	size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
sl@0	2290	if (width > stringLen) {
sl@0	2291	size += (width - stringLen);
sl@0	2292	}
sl@0	2293	break;
sl@0	2294	case 'c':
sl@0	2295	if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
sl@0	2296	objv[objIndex], &intValue) != TCL_OK) {
sl@0	2297	goto fmtError;
sl@0	2298	}
sl@0	2299	whichValue = CHAR_VALUE;
sl@0	2300	size = width + TCL_UTF_MAX;
sl@0	2301	break;
sl@0	2302	case 'e':
sl@0	2303	case 'E':
sl@0	2304	case 'f':
sl@0	2305	case 'g':
sl@0	2306	case 'G':
sl@0	2307	if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
sl@0	2308	objv[objIndex], &doubleValue) != TCL_OK) {
sl@0	2309	goto fmtError;
sl@0	2310	}
sl@0	2311	whichValue = DOUBLE_VALUE;
sl@0	2312	size = MAX_FLOAT_SIZE;
sl@0	2313	if (precision > 10) {
sl@0	2314	size += precision;
sl@0	2315	}
sl@0	2316	break;
sl@0	2317	case 0:
sl@0	2318	Tcl_SetResult(interp,
sl@0	2319	"format string ended in middle of field specifier",
sl@0	2320	TCL_STATIC);
sl@0	2321	goto fmtError;
sl@0	2322	default:
sl@0	2323	{
sl@0	2324	char buf[40];
sl@0	2325
sl@0	2326	sprintf(buf, "bad field specifier \"%c\"", *format);
sl@0	2327	Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0	2328	goto fmtError;
sl@0	2329	}
sl@0	2330	}
sl@0	2331	objIndex++;
sl@0	2332	format++;
sl@0	2333
sl@0	2334	/*
sl@0	2335	* Make sure that there's enough space to hold the formatted
sl@0	2336	* result, then format it.
sl@0	2337	*/
sl@0	2338
sl@0	2339	doField:
sl@0	2340	if (width > size) {
sl@0	2341	size = width;
sl@0	2342	}
sl@0	2343	if (noPercent) {
sl@0	2344	Tcl_AppendToObj(resultPtr, ptrValue, size);
sl@0	2345	} else {
sl@0	2346	if (size > dstSize) {
sl@0	2347	if (dst != staticBuf) {
sl@0	2348	ckfree(dst);
sl@0	2349	}
sl@0	2350	dst = (char *) ckalloc((unsigned) (size + 1));
sl@0	2351	dstSize = size;
sl@0	2352	}
sl@0	2353	switch (whichValue) {
sl@0	2354	case DOUBLE_VALUE:
sl@0	2355	sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
sl@0	2356	break;
sl@0	2357	case WIDE_VALUE:
sl@0	2358	sprintf(dst, newFormat, wideValue);
sl@0	2359	break;
sl@0	2360	case INT_VALUE:
sl@0	2361	if (useShort) {
sl@0	2362	sprintf(dst, newFormat, (short) intValue);
sl@0	2363	} else {
sl@0	2364	sprintf(dst, newFormat, intValue);
sl@0	2365	}
sl@0	2366	break;
sl@0	2367	case CHAR_VALUE: {
sl@0	2368	char *ptr;
sl@0	2369	char padChar = (gotZero ? '0' : ' ');
sl@0	2370	ptr = dst;
sl@0	2371	if (!gotMinus) {
sl@0	2372	for ( ; --width > 0; ptr++) {
sl@0	2373	*ptr = padChar;
sl@0	2374	}
sl@0	2375	}
sl@0	2376	ptr += Tcl_UniCharToUtf(intValue, ptr);
sl@0	2377	for ( ; --width > 0; ptr++) {
sl@0	2378	*ptr = padChar;
sl@0	2379	}
sl@0	2380	*ptr = '\0';
sl@0	2381	break;
sl@0	2382	}
sl@0	2383	case STRING_VALUE: {
sl@0	2384	char *ptr;
sl@0	2385	char padChar = (gotZero ? '0' : ' ');
sl@0	2386	int pad;
sl@0	2387
sl@0	2388	ptr = dst;
sl@0	2389	if (width > stringLen) {
sl@0	2390	pad = width - stringLen;
sl@0	2391	} else {
sl@0	2392	pad = 0;
sl@0	2393	}
sl@0	2394
sl@0	2395	if (!gotMinus) {
sl@0	2396	while (pad > 0) {
sl@0	2397	*ptr++ = padChar;
sl@0	2398	pad--;
sl@0	2399	}
sl@0	2400	}
sl@0	2401
sl@0	2402	size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
sl@0	2403	if (size) {
sl@0	2404	memcpy(ptr, ptrValue, (size_t) size);
sl@0	2405	ptr += size;
sl@0	2406	}
sl@0	2407	while (pad > 0) {
sl@0	2408	*ptr++ = padChar;
sl@0	2409	pad--;
sl@0	2410	}
sl@0	2411	*ptr = '\0';
sl@0	2412	break;
sl@0	2413	}
sl@0	2414	default:
sl@0	2415	sprintf(dst, newFormat, ptrValue);
sl@0	2416	break;
sl@0	2417	}
sl@0	2418	Tcl_AppendToObj(resultPtr, dst, -1);
sl@0	2419	}
sl@0	2420	}
sl@0	2421
sl@0	2422	Tcl_SetObjResult(interp, resultPtr);
sl@0	2423	if (dst != staticBuf) {
sl@0	2424	ckfree(dst);
sl@0	2425	}
sl@0	2426	return TCL_OK;
sl@0	2427
sl@0	2428	mixedXPG:
sl@0	2429	Tcl_SetResult(interp,
sl@0	2430	"cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
sl@0	2431	goto fmtError;
sl@0	2432
sl@0	2433	badIndex:
sl@0	2434	if (gotXpg) {
sl@0	2435	Tcl_SetResult(interp,
sl@0	2436	"\"%n$\" argument index out of range", TCL_STATIC);
sl@0	2437	} else {
sl@0	2438	Tcl_SetResult(interp,
sl@0	2439	"not enough arguments for all format specifiers", TCL_STATIC);
sl@0	2440	}
sl@0	2441
sl@0	2442	fmtError:
sl@0	2443	if (dst != staticBuf) {
sl@0	2444	ckfree(dst);
sl@0	2445	}
sl@0	2446	Tcl_DecrRefCount(resultPtr);
sl@0	2447	return TCL_ERROR;
sl@0	2448	}
sl@0	2449
sl@0	2450	/*
sl@0	2451	* Local Variables:
sl@0	2452	* mode: c
sl@0	2453	* c-basic-offset: 4
sl@0	2454	* fill-column: 78
sl@0	2455	* End:
sl@0	2456	*/
sl@0	2457

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--