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

sl@0	1	/*
sl@0	2	* tclIOCmd.c --
sl@0	3	*
sl@0	4	* Contains the definitions of most of the Tcl commands relating to IO.
sl@0	5	*
sl@0	6	* Copyright (c) 1995-1997 Sun Microsystems, Inc.
sl@0	7	*
sl@0	8	* See the file "license.terms" for information on usage and redistribution
sl@0	9	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	10	*
sl@0	11	* RCS: @(#) $Id: tclIOCmd.c,v 1.15.2.2 2004/07/16 22:38:37 andreas_kupries Exp $
sl@0	12	*/
sl@0	13
sl@0	14	#include "tclInt.h"
sl@0	15	#include "tclPort.h"
sl@0	16
sl@0	17	/*
sl@0	18	* Callback structure for accept callback in a TCP server.
sl@0	19	*/
sl@0	20
sl@0	21	typedef struct AcceptCallback {
sl@0	22	char script; / Script to invoke. */
sl@0	23	Tcl_Interp interp; / Interpreter in which to run it. */
sl@0	24	} AcceptCallback;
sl@0	25
sl@0	26	/*
sl@0	27	* Static functions for this file:
sl@0	28	*/
sl@0	29
sl@0	30	static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
sl@0	31	Tcl_Channel chan, char *address, int port));
sl@0	32	static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	33	AcceptCallback *acceptCallbackPtr));
sl@0	34	static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
sl@0	35	ClientData clientData, Tcl_Interp *interp));
sl@0	36	static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
sl@0	37	static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
sl@0	38	Tcl_Interp interp, AcceptCallback acceptCallbackPtr));
sl@0	39
sl@0	40	/*
sl@0	41	*----------------------------------------------------------------------
sl@0	42	*
sl@0	43	* Tcl_PutsObjCmd --
sl@0	44	*
sl@0	45	* This procedure is invoked to process the "puts" Tcl command.
sl@0	46	* See the user documentation for details on what it does.
sl@0	47	*
sl@0	48	* Results:
sl@0	49	* A standard Tcl result.
sl@0	50	*
sl@0	51	* Side effects:
sl@0	52	* Produces output on a channel.
sl@0	53	*
sl@0	54	*----------------------------------------------------------------------
sl@0	55	*/
sl@0	56
sl@0	57	/* ARGSUSED */
sl@0	58	int
sl@0	59	Tcl_PutsObjCmd(dummy, interp, objc, objv)
sl@0	60	ClientData dummy; /* Not used. */
sl@0	61	Tcl_Interp interp; / Current interpreter. */
sl@0	62	int objc; /* Number of arguments. */
sl@0	63	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	64	{
sl@0	65	Tcl_Channel chan; /* The channel to puts on. */
sl@0	66	Tcl_Obj string; / String to write. */
sl@0	67	int newline; /* Add a newline at end? */
sl@0	68	char channelId; / Name of channel for puts. */
sl@0	69	int result; /* Result of puts operation. */
sl@0	70	int mode; /* Mode in which channel is opened. */
sl@0	71
sl@0	72	switch (objc) {
sl@0	73	case 2: /* puts $x */
sl@0	74	string = objv[1];
sl@0	75	newline = 1;
sl@0	76	channelId = "stdout";
sl@0	77	break;
sl@0	78
sl@0	79	case 3: /* puts -nonewline $x or puts $chan $x */
sl@0	80	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
sl@0	81	newline = 0;
sl@0	82	channelId = "stdout";
sl@0	83	} else {
sl@0	84	newline = 1;
sl@0	85	channelId = Tcl_GetString(objv[1]);
sl@0	86	}
sl@0	87	string = objv[2];
sl@0	88	break;
sl@0	89
sl@0	90	case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */
sl@0	91	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
sl@0	92	channelId = Tcl_GetString(objv[2]);
sl@0	93	string = objv[3];
sl@0	94	} else {
sl@0	95	/*
sl@0	96	* The code below provides backwards compatibility with an
sl@0	97	* old form of the command that is no longer recommended
sl@0	98	* or documented.
sl@0	99	*/
sl@0	100
sl@0	101	char *arg;
sl@0	102	int length;
sl@0	103
sl@0	104	arg = Tcl_GetStringFromObj(objv[3], &length);
sl@0	105	if ((length != 9) \|\| (strncmp(arg, "nonewline", (size_t) length) != 0)) {
sl@0	106	Tcl_AppendResult(interp, "bad argument \"", arg,
sl@0	107	"\": should be \"nonewline\"",
sl@0	108	(char *) NULL);
sl@0	109	return TCL_ERROR;
sl@0	110	}
sl@0	111	channelId = Tcl_GetString(objv[1]);
sl@0	112	string = objv[2];
sl@0	113	}
sl@0	114	newline = 0;
sl@0	115	break;
sl@0	116
sl@0	117	default: /* puts or puts some bad number of arguments... */
sl@0	118	Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
sl@0	119	return TCL_ERROR;
sl@0	120	}
sl@0	121
sl@0	122	chan = Tcl_GetChannel(interp, channelId, &mode);
sl@0	123	if (chan == (Tcl_Channel) NULL) {
sl@0	124	return TCL_ERROR;
sl@0	125	}
sl@0	126	if ((mode & TCL_WRITABLE) == 0) {
sl@0	127	Tcl_AppendResult(interp, "channel \"", channelId,
sl@0	128	"\" wasn't opened for writing", (char *) NULL);
sl@0	129	return TCL_ERROR;
sl@0	130	}
sl@0	131
sl@0	132	result = Tcl_WriteObj(chan, string);
sl@0	133	if (result < 0) {
sl@0	134	goto error;
sl@0	135	}
sl@0	136	if (newline != 0) {
sl@0	137	result = Tcl_WriteChars(chan, "\n", 1);
sl@0	138	if (result < 0) {
sl@0	139	goto error;
sl@0	140	}
sl@0	141	}
sl@0	142	return TCL_OK;
sl@0	143
sl@0	144	error:
sl@0	145	Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
sl@0	146	Tcl_PosixError(interp), (char *) NULL);
sl@0	147	return TCL_ERROR;
sl@0	148	}
sl@0	149
sl@0	150	/*
sl@0	151	*----------------------------------------------------------------------
sl@0	152	*
sl@0	153	* Tcl_FlushObjCmd --
sl@0	154	*
sl@0	155	* This procedure is called to process the Tcl "flush" command.
sl@0	156	* See the user documentation for details on what it does.
sl@0	157	*
sl@0	158	* Results:
sl@0	159	* A standard Tcl result.
sl@0	160	*
sl@0	161	* Side effects:
sl@0	162	* May cause output to appear on the specified channel.
sl@0	163	*
sl@0	164	*----------------------------------------------------------------------
sl@0	165	*/
sl@0	166
sl@0	167	/* ARGSUSED */
sl@0	168	int
sl@0	169	Tcl_FlushObjCmd(dummy, interp, objc, objv)
sl@0	170	ClientData dummy; /* Not used. */
sl@0	171	Tcl_Interp interp; / Current interpreter. */
sl@0	172	int objc; /* Number of arguments. */
sl@0	173	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	174	{
sl@0	175	Tcl_Channel chan; /* The channel to flush on. */
sl@0	176	char *channelId;
sl@0	177	int mode;
sl@0	178
sl@0	179	if (objc != 2) {
sl@0	180	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
sl@0	181	return TCL_ERROR;
sl@0	182	}
sl@0	183	channelId = Tcl_GetString(objv[1]);
sl@0	184	chan = Tcl_GetChannel(interp, channelId, &mode);
sl@0	185	if (chan == (Tcl_Channel) NULL) {
sl@0	186	return TCL_ERROR;
sl@0	187	}
sl@0	188	if ((mode & TCL_WRITABLE) == 0) {
sl@0	189	Tcl_AppendResult(interp, "channel \"", channelId,
sl@0	190	"\" wasn't opened for writing", (char *) NULL);
sl@0	191	return TCL_ERROR;
sl@0	192	}
sl@0	193
sl@0	194	if (Tcl_Flush(chan) != TCL_OK) {
sl@0	195	Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
sl@0	196	Tcl_PosixError(interp), (char *) NULL);
sl@0	197	return TCL_ERROR;
sl@0	198	}
sl@0	199	return TCL_OK;
sl@0	200	}
sl@0	201
sl@0	202	/*
sl@0	203	*----------------------------------------------------------------------
sl@0	204	*
sl@0	205	* Tcl_GetsObjCmd --
sl@0	206	*
sl@0	207	* This procedure is called to process the Tcl "gets" command.
sl@0	208	* See the user documentation for details on what it does.
sl@0	209	*
sl@0	210	* Results:
sl@0	211	* A standard Tcl result.
sl@0	212	*
sl@0	213	* Side effects:
sl@0	214	* May consume input from channel.
sl@0	215	*
sl@0	216	*----------------------------------------------------------------------
sl@0	217	*/
sl@0	218
sl@0	219	/* ARGSUSED */
sl@0	220	int
sl@0	221	Tcl_GetsObjCmd(dummy, interp, objc, objv)
sl@0	222	ClientData dummy; /* Not used. */
sl@0	223	Tcl_Interp interp; / Current interpreter. */
sl@0	224	int objc; /* Number of arguments. */
sl@0	225	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	226	{
sl@0	227	Tcl_Channel chan; /* The channel to read from. */
sl@0	228	int lineLen; /* Length of line just read. */
sl@0	229	int mode; /* Mode in which channel is opened. */
sl@0	230	char *name;
sl@0	231	Tcl_Obj resultPtr, linePtr;
sl@0	232
sl@0	233	if ((objc != 2) && (objc != 3)) {
sl@0	234	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
sl@0	235	return TCL_ERROR;
sl@0	236	}
sl@0	237	name = Tcl_GetString(objv[1]);
sl@0	238	chan = Tcl_GetChannel(interp, name, &mode);
sl@0	239	if (chan == (Tcl_Channel) NULL) {
sl@0	240	return TCL_ERROR;
sl@0	241	}
sl@0	242	if ((mode & TCL_READABLE) == 0) {
sl@0	243	Tcl_AppendResult(interp, "channel \"", name,
sl@0	244	"\" wasn't opened for reading", (char *) NULL);
sl@0	245	return TCL_ERROR;
sl@0	246	}
sl@0	247
sl@0	248	linePtr = Tcl_NewObj();
sl@0	249
sl@0	250	lineLen = Tcl_GetsObj(chan, linePtr);
sl@0	251	if (lineLen < 0) {
sl@0	252	if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
sl@0	253	Tcl_DecrRefCount(linePtr);
sl@0	254	Tcl_ResetResult(interp);
sl@0	255	Tcl_AppendResult(interp, "error reading \"", name, "\": ",
sl@0	256	Tcl_PosixError(interp), (char *) NULL);
sl@0	257	return TCL_ERROR;
sl@0	258	}
sl@0	259	lineLen = -1;
sl@0	260	}
sl@0	261	if (objc == 3) {
sl@0	262	if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
sl@0	263	TCL_LEAVE_ERR_MSG) == NULL) {
sl@0	264	Tcl_DecrRefCount(linePtr);
sl@0	265	return TCL_ERROR;
sl@0	266	}
sl@0	267	resultPtr = Tcl_GetObjResult(interp);
sl@0	268	Tcl_SetIntObj(resultPtr, lineLen);
sl@0	269	return TCL_OK;
sl@0	270	} else {
sl@0	271	Tcl_SetObjResult(interp, linePtr);
sl@0	272	}
sl@0	273	return TCL_OK;
sl@0	274	}
sl@0	275
sl@0	276	/*
sl@0	277	*----------------------------------------------------------------------
sl@0	278	*
sl@0	279	* Tcl_ReadObjCmd --
sl@0	280	*
sl@0	281	* This procedure is invoked to process the Tcl "read" command.
sl@0	282	* See the user documentation for details on what it does.
sl@0	283	*
sl@0	284	* Results:
sl@0	285	* A standard Tcl result.
sl@0	286	*
sl@0	287	* Side effects:
sl@0	288	* May consume input from channel.
sl@0	289	*
sl@0	290	*----------------------------------------------------------------------
sl@0	291	*/
sl@0	292
sl@0	293	/* ARGSUSED */
sl@0	294	int
sl@0	295	Tcl_ReadObjCmd(dummy, interp, objc, objv)
sl@0	296	ClientData dummy; /* Not used. */
sl@0	297	Tcl_Interp interp; / Current interpreter. */
sl@0	298	int objc; /* Number of arguments. */
sl@0	299	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	300	{
sl@0	301	Tcl_Channel chan; /* The channel to read from. */
sl@0	302	int newline, i; /* Discard newline at end? */
sl@0	303	int toRead; /* How many bytes to read? */
sl@0	304	int charactersRead; /* How many characters were read? */
sl@0	305	int mode; /* Mode in which channel is opened. */
sl@0	306	char *name;
sl@0	307	Tcl_Obj *resultPtr;
sl@0	308
sl@0	309	if ((objc != 2) && (objc != 3)) {
sl@0	310	argerror:
sl@0	311	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
sl@0	312	Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
sl@0	313	" ?-nonewline? channelId\"", (char *) NULL);
sl@0	314	return TCL_ERROR;
sl@0	315	}
sl@0	316
sl@0	317	i = 1;
sl@0	318	newline = 0;
sl@0	319	if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
sl@0	320	newline = 1;
sl@0	321	i++;
sl@0	322	}
sl@0	323
sl@0	324	if (i == objc) {
sl@0	325	goto argerror;
sl@0	326	}
sl@0	327
sl@0	328	name = Tcl_GetString(objv[i]);
sl@0	329	chan = Tcl_GetChannel(interp, name, &mode);
sl@0	330	if (chan == (Tcl_Channel) NULL) {
sl@0	331	return TCL_ERROR;
sl@0	332	}
sl@0	333	if ((mode & TCL_READABLE) == 0) {
sl@0	334	Tcl_AppendResult(interp, "channel \"", name,
sl@0	335	"\" wasn't opened for reading", (char *) NULL);
sl@0	336	return TCL_ERROR;
sl@0	337	}
sl@0	338	i++; /* Consumed channel name. */
sl@0	339
sl@0	340	/*
sl@0	341	* Compute how many bytes to read, and see whether the final
sl@0	342	* newline should be dropped.
sl@0	343	*/
sl@0	344
sl@0	345	toRead = -1;
sl@0	346	if (i < objc) {
sl@0	347	char *arg;
sl@0	348
sl@0	349	arg = Tcl_GetString(objv[i]);
sl@0	350	if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
sl@0	351	if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
sl@0	352	return TCL_ERROR;
sl@0	353	}
sl@0	354	} else if (strcmp(arg, "nonewline") == 0) {
sl@0	355	newline = 1;
sl@0	356	} else {
sl@0	357	Tcl_AppendResult(interp, "bad argument \"", arg,
sl@0	358	"\": should be \"nonewline\"", (char *) NULL);
sl@0	359	return TCL_ERROR;
sl@0	360	}
sl@0	361	}
sl@0	362
sl@0	363	resultPtr = Tcl_NewObj();
sl@0	364	Tcl_IncrRefCount(resultPtr);
sl@0	365	charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
sl@0	366	if (charactersRead < 0) {
sl@0	367	Tcl_ResetResult(interp);
sl@0	368	Tcl_AppendResult(interp, "error reading \"", name, "\": ",
sl@0	369	Tcl_PosixError(interp), (char *) NULL);
sl@0	370	Tcl_DecrRefCount(resultPtr);
sl@0	371	return TCL_ERROR;
sl@0	372	}
sl@0	373
sl@0	374	/*
sl@0	375	* If requested, remove the last newline in the channel if at EOF.
sl@0	376	*/
sl@0	377
sl@0	378	if ((charactersRead > 0) && (newline != 0)) {
sl@0	379	char *result;
sl@0	380	int length;
sl@0	381
sl@0	382	result = Tcl_GetStringFromObj(resultPtr, &length);
sl@0	383	if (result[length - 1] == '\n') {
sl@0	384	Tcl_SetObjLength(resultPtr, length - 1);
sl@0	385	}
sl@0	386	}
sl@0	387	Tcl_SetObjResult(interp, resultPtr);
sl@0	388	Tcl_DecrRefCount(resultPtr);
sl@0	389	return TCL_OK;
sl@0	390	}
sl@0	391
sl@0	392	/*
sl@0	393	*----------------------------------------------------------------------
sl@0	394	*
sl@0	395	* Tcl_SeekObjCmd --
sl@0	396	*
sl@0	397	* This procedure is invoked to process the Tcl "seek" command. See
sl@0	398	* the user documentation for details on what it does.
sl@0	399	*
sl@0	400	* Results:
sl@0	401	* A standard Tcl result.
sl@0	402	*
sl@0	403	* Side effects:
sl@0	404	* Moves the position of the access point on the specified channel.
sl@0	405	* May flush queued output.
sl@0	406	*
sl@0	407	*----------------------------------------------------------------------
sl@0	408	*/
sl@0	409
sl@0	410	/* ARGSUSED */
sl@0	411	int
sl@0	412	Tcl_SeekObjCmd(clientData, interp, objc, objv)
sl@0	413	ClientData clientData; /* Not used. */
sl@0	414	Tcl_Interp interp; / Current interpreter. */
sl@0	415	int objc; /* Number of arguments. */
sl@0	416	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	417	{
sl@0	418	Tcl_Channel chan; /* The channel to tell on. */
sl@0	419	Tcl_WideInt offset; /* Where to seek? */
sl@0	420	int mode; /* How to seek? */
sl@0	421	Tcl_WideInt result; /* Of calling Tcl_Seek. */
sl@0	422	char *chanName;
sl@0	423	int optionIndex;
sl@0	424	static CONST char *originOptions[] = {
sl@0	425	"start", "current", "end", (char *) NULL
sl@0	426	};
sl@0	427	static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
sl@0	428
sl@0	429	if ((objc != 3) && (objc != 4)) {
sl@0	430	Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
sl@0	431	return TCL_ERROR;
sl@0	432	}
sl@0	433	chanName = Tcl_GetString(objv[1]);
sl@0	434	chan = Tcl_GetChannel(interp, chanName, NULL);
sl@0	435	if (chan == (Tcl_Channel) NULL) {
sl@0	436	return TCL_ERROR;
sl@0	437	}
sl@0	438	if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
sl@0	439	return TCL_ERROR;
sl@0	440	}
sl@0	441	mode = SEEK_SET;
sl@0	442	if (objc == 4) {
sl@0	443	if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
sl@0	444	&optionIndex) != TCL_OK) {
sl@0	445	return TCL_ERROR;
sl@0	446	}
sl@0	447	mode = modeArray[optionIndex];
sl@0	448	}
sl@0	449
sl@0	450	result = Tcl_Seek(chan, offset, mode);
sl@0	451	if (result == Tcl_LongAsWide(-1)) {
sl@0	452	Tcl_AppendResult(interp, "error during seek on \"",
sl@0	453	chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
sl@0	454	return TCL_ERROR;
sl@0	455	}
sl@0	456	return TCL_OK;
sl@0	457	}
sl@0	458
sl@0	459	/*
sl@0	460	*----------------------------------------------------------------------
sl@0	461	*
sl@0	462	* Tcl_TellObjCmd --
sl@0	463	*
sl@0	464	* This procedure is invoked to process the Tcl "tell" command.
sl@0	465	* See the user documentation for details on what it does.
sl@0	466	*
sl@0	467	* Results:
sl@0	468	* A standard Tcl result.
sl@0	469	*
sl@0	470	* Side effects:
sl@0	471	* None.
sl@0	472	*
sl@0	473	*----------------------------------------------------------------------
sl@0	474	*/
sl@0	475
sl@0	476	/* ARGSUSED */
sl@0	477	int
sl@0	478	Tcl_TellObjCmd(clientData, interp, objc, objv)
sl@0	479	ClientData clientData; /* Not used. */
sl@0	480	Tcl_Interp interp; / Current interpreter. */
sl@0	481	int objc; /* Number of arguments. */
sl@0	482	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	483	{
sl@0	484	Tcl_Channel chan; /* The channel to tell on. */
sl@0	485	char *chanName;
sl@0	486
sl@0	487	if (objc != 2) {
sl@0	488	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
sl@0	489	return TCL_ERROR;
sl@0	490	}
sl@0	491	/*
sl@0	492	* Try to find a channel with the right name and permissions in
sl@0	493	* the IO channel table of this interpreter.
sl@0	494	*/
sl@0	495
sl@0	496	chanName = Tcl_GetString(objv[1]);
sl@0	497	chan = Tcl_GetChannel(interp, chanName, NULL);
sl@0	498	if (chan == (Tcl_Channel) NULL) {
sl@0	499	return TCL_ERROR;
sl@0	500	}
sl@0	501	Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
sl@0	502	return TCL_OK;
sl@0	503	}
sl@0	504
sl@0	505	/*
sl@0	506	*----------------------------------------------------------------------
sl@0	507	*
sl@0	508	* Tcl_CloseObjCmd --
sl@0	509	*
sl@0	510	* This procedure is invoked to process the Tcl "close" command.
sl@0	511	* See the user documentation for details on what it does.
sl@0	512	*
sl@0	513	* Results:
sl@0	514	* A standard Tcl result.
sl@0	515	*
sl@0	516	* Side effects:
sl@0	517	* May discard queued input; may flush queued output.
sl@0	518	*
sl@0	519	*----------------------------------------------------------------------
sl@0	520	*/
sl@0	521
sl@0	522	/* ARGSUSED */
sl@0	523	int
sl@0	524	Tcl_CloseObjCmd(clientData, interp, objc, objv)
sl@0	525	ClientData clientData; /* Not used. */
sl@0	526	Tcl_Interp interp; / Current interpreter. */
sl@0	527	int objc; /* Number of arguments. */
sl@0	528	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	529	{
sl@0	530	Tcl_Channel chan; /* The channel to close. */
sl@0	531	char *arg;
sl@0	532
sl@0	533	if (objc != 2) {
sl@0	534	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
sl@0	535	return TCL_ERROR;
sl@0	536	}
sl@0	537
sl@0	538	arg = Tcl_GetString(objv[1]);
sl@0	539	chan = Tcl_GetChannel(interp, arg, NULL);
sl@0	540	if (chan == (Tcl_Channel) NULL) {
sl@0	541	return TCL_ERROR;
sl@0	542	}
sl@0	543
sl@0	544	if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
sl@0	545	/*
sl@0	546	* If there is an error message and it ends with a newline, remove
sl@0	547	* the newline. This is done for command pipeline channels where the
sl@0	548	* error output from the subprocesses is stored in interp's result.
sl@0	549	*
sl@0	550	* NOTE: This is likely to not have any effect on regular error
sl@0	551	* messages produced by drivers during the closing of a channel,
sl@0	552	* because the Tcl convention is that such error messages do not
sl@0	553	* have a terminating newline.
sl@0	554	*/
sl@0	555
sl@0	556	Tcl_Obj *resultPtr;
sl@0	557	char *string;
sl@0	558	int len;
sl@0	559
sl@0	560	resultPtr = Tcl_GetObjResult(interp);
sl@0	561	string = Tcl_GetStringFromObj(resultPtr, &len);
sl@0	562	if ((len > 0) && (string[len - 1] == '\n')) {
sl@0	563	Tcl_SetObjLength(resultPtr, len - 1);
sl@0	564	}
sl@0	565	return TCL_ERROR;
sl@0	566	}
sl@0	567
sl@0	568	return TCL_OK;
sl@0	569	}
sl@0	570
sl@0	571	/*
sl@0	572	*----------------------------------------------------------------------
sl@0	573	*
sl@0	574	* Tcl_FconfigureObjCmd --
sl@0	575	*
sl@0	576	* This procedure is invoked to process the Tcl "fconfigure" command.
sl@0	577	* See the user documentation for details on what it does.
sl@0	578	*
sl@0	579	* Results:
sl@0	580	* A standard Tcl result.
sl@0	581	*
sl@0	582	* Side effects:
sl@0	583	* May modify the behavior of an IO channel.
sl@0	584	*
sl@0	585	*----------------------------------------------------------------------
sl@0	586	*/
sl@0	587
sl@0	588	/* ARGSUSED */
sl@0	589	int
sl@0	590	Tcl_FconfigureObjCmd(clientData, interp, objc, objv)
sl@0	591	ClientData clientData; /* Not used. */
sl@0	592	Tcl_Interp interp; / Current interpreter. */
sl@0	593	int objc; /* Number of arguments. */
sl@0	594	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	595	{
sl@0	596	char chanName, optionName, *valueName;
sl@0	597	Tcl_Channel chan; /* The channel to set a mode on. */
sl@0	598	int i; /* Iterate over arg-value pairs. */
sl@0	599	Tcl_DString ds; /* DString to hold result of
sl@0	600	* calling Tcl_GetChannelOption. */
sl@0	601
sl@0	602	if ((objc < 2) \|\| (((objc % 2) == 1) && (objc != 3))) {
sl@0	603	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	604	"channelId ?optionName? ?value? ?optionName value?...");
sl@0	605	return TCL_ERROR;
sl@0	606	}
sl@0	607	chanName = Tcl_GetString(objv[1]);
sl@0	608	chan = Tcl_GetChannel(interp, chanName, NULL);
sl@0	609	if (chan == (Tcl_Channel) NULL) {
sl@0	610	return TCL_ERROR;
sl@0	611	}
sl@0	612	if (objc == 2) {
sl@0	613	Tcl_DStringInit(&ds);
sl@0	614	if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
sl@0	615	Tcl_DStringFree(&ds);
sl@0	616	return TCL_ERROR;
sl@0	617	}
sl@0	618	Tcl_DStringResult(interp, &ds);
sl@0	619	return TCL_OK;
sl@0	620	}
sl@0	621	if (objc == 3) {
sl@0	622	Tcl_DStringInit(&ds);
sl@0	623	optionName = Tcl_GetString(objv[2]);
sl@0	624	if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
sl@0	625	Tcl_DStringFree(&ds);
sl@0	626	return TCL_ERROR;
sl@0	627	}
sl@0	628	Tcl_DStringResult(interp, &ds);
sl@0	629	return TCL_OK;
sl@0	630	}
sl@0	631	for (i = 3; i < objc; i += 2) {
sl@0	632	optionName = Tcl_GetString(objv[i-1]);
sl@0	633	valueName = Tcl_GetString(objv[i]);
sl@0	634	if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
sl@0	635	!= TCL_OK) {
sl@0	636	return TCL_ERROR;
sl@0	637	}
sl@0	638	}
sl@0	639	return TCL_OK;
sl@0	640	}
sl@0	641
sl@0	642	/*
sl@0	643	*---------------------------------------------------------------------------
sl@0	644	*
sl@0	645	* Tcl_EofObjCmd --
sl@0	646	*
sl@0	647	* This procedure is invoked to process the Tcl "eof" command.
sl@0	648	* See the user documentation for details on what it does.
sl@0	649	*
sl@0	650	* Results:
sl@0	651	* A standard Tcl result.
sl@0	652	*
sl@0	653	* Side effects:
sl@0	654	* Sets interp's result to boolean true or false depending on whether
sl@0	655	* the specified channel has an EOF condition.
sl@0	656	*
sl@0	657	*---------------------------------------------------------------------------
sl@0	658	*/
sl@0	659
sl@0	660	/* ARGSUSED */
sl@0	661	int
sl@0	662	Tcl_EofObjCmd(unused, interp, objc, objv)
sl@0	663	ClientData unused; /* Not used. */
sl@0	664	Tcl_Interp interp; / Current interpreter. */
sl@0	665	int objc; /* Number of arguments. */
sl@0	666	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	667	{
sl@0	668	Tcl_Channel chan;
sl@0	669	int dummy;
sl@0	670	char *arg;
sl@0	671
sl@0	672	if (objc != 2) {
sl@0	673	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
sl@0	674	return TCL_ERROR;
sl@0	675	}
sl@0	676
sl@0	677	arg = Tcl_GetString(objv[1]);
sl@0	678	chan = Tcl_GetChannel(interp, arg, &dummy);
sl@0	679	if (chan == NULL) {
sl@0	680	return TCL_ERROR;
sl@0	681	}
sl@0	682
sl@0	683	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan));
sl@0	684	return TCL_OK;
sl@0	685	}
sl@0	686
sl@0	687	/*
sl@0	688	*----------------------------------------------------------------------
sl@0	689	*
sl@0	690	* Tcl_ExecObjCmd --
sl@0	691	*
sl@0	692	* This procedure is invoked to process the "exec" Tcl command.
sl@0	693	* See the user documentation for details on what it does.
sl@0	694	*
sl@0	695	* Results:
sl@0	696	* A standard Tcl result.
sl@0	697	*
sl@0	698	* Side effects:
sl@0	699	* See the user documentation.
sl@0	700	*
sl@0	701	*----------------------------------------------------------------------
sl@0	702	*/
sl@0	703
sl@0	704	/* ARGSUSED */
sl@0	705	int
sl@0	706	Tcl_ExecObjCmd(dummy, interp, objc, objv)
sl@0	707	ClientData dummy; /* Not used. */
sl@0	708	Tcl_Interp interp; / Current interpreter. */
sl@0	709	int objc; /* Number of arguments. */
sl@0	710	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	711	{
sl@0	712	#ifdef MAC_TCL
sl@0	713
sl@0	714	Tcl_AppendResult(interp, "exec not implemented under Mac OS",
sl@0	715	(char *)NULL);
sl@0	716	return TCL_ERROR;
sl@0	717
sl@0	718	#else /* !MAC_TCL */
sl@0	719
sl@0	720	/*
sl@0	721	* This procedure generates an argv array for the string arguments. It
sl@0	722	* starts out with stack-allocated space but uses dynamically-allocated
sl@0	723	* storage if needed.
sl@0	724	*/
sl@0	725
sl@0	726	#define NUM_ARGS 20
sl@0	727	Tcl_Obj *resultPtr;
sl@0	728	CONST char **argv;
sl@0	729	char *string;
sl@0	730	Tcl_Channel chan;
sl@0	731	CONST char *argStorage[NUM_ARGS];
sl@0	732	int argc, background, i, index, keepNewline, result, skip, length;
sl@0	733	static CONST char *options[] = {
sl@0	734	"-keepnewline", "--", NULL
sl@0	735	};
sl@0	736	enum options {
sl@0	737	EXEC_KEEPNEWLINE, EXEC_LAST
sl@0	738	};
sl@0	739
sl@0	740	/*
sl@0	741	* Check for a leading "-keepnewline" argument.
sl@0	742	*/
sl@0	743
sl@0	744	keepNewline = 0;
sl@0	745	for (skip = 1; skip < objc; skip++) {
sl@0	746	string = Tcl_GetString(objv[skip]);
sl@0	747	if (string[0] != '-') {
sl@0	748	break;
sl@0	749	}
sl@0	750	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
sl@0	751	TCL_EXACT, &index) != TCL_OK) {
sl@0	752	return TCL_ERROR;
sl@0	753	}
sl@0	754	if (index == EXEC_KEEPNEWLINE) {
sl@0	755	keepNewline = 1;
sl@0	756	} else {
sl@0	757	skip++;
sl@0	758	break;
sl@0	759	}
sl@0	760	}
sl@0	761	if (objc <= skip) {
sl@0	762	Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
sl@0	763	return TCL_ERROR;
sl@0	764	}
sl@0	765
sl@0	766	/*
sl@0	767	* See if the command is to be run in background.
sl@0	768	*/
sl@0	769
sl@0	770	background = 0;
sl@0	771	string = Tcl_GetString(objv[objc - 1]);
sl@0	772	if ((string[0] == '&') && (string[1] == '\0')) {
sl@0	773	objc--;
sl@0	774	background = 1;
sl@0	775	}
sl@0	776
sl@0	777	/*
sl@0	778	* Create the string argument array "argv". Make sure argv is large
sl@0	779	* enough to hold the argc arguments plus 1 extra for the zero
sl@0	780	* end-of-argv word.
sl@0	781	*/
sl@0	782
sl@0	783	argv = argStorage;
sl@0	784	argc = objc - skip;
sl@0	785	if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
sl@0	786	argv = (CONST char *) ckalloc((unsigned)(argc + 1) sizeof(char *));
sl@0	787	}
sl@0	788
sl@0	789	/*
sl@0	790	* Copy the string conversions of each (post option) object into the
sl@0	791	* argument vector.
sl@0	792	*/
sl@0	793
sl@0	794	for (i = 0; i < argc; i++) {
sl@0	795	argv[i] = Tcl_GetString(objv[i + skip]);
sl@0	796	}
sl@0	797	argv[argc] = NULL;
sl@0	798	chan = Tcl_OpenCommandChannel(interp, argc, argv,
sl@0	799	(background ? 0 : TCL_STDOUT \| TCL_STDERR));
sl@0	800
sl@0	801	/*
sl@0	802	* Free the argv array if malloc'ed storage was used.
sl@0	803	*/
sl@0	804
sl@0	805	if (argv != argStorage) {
sl@0	806	ckfree((char *)argv);
sl@0	807	}
sl@0	808
sl@0	809	if (chan == (Tcl_Channel) NULL) {
sl@0	810	return TCL_ERROR;
sl@0	811	}
sl@0	812
sl@0	813	if (background) {
sl@0	814	/*
sl@0	815	* Store the list of PIDs from the pipeline in interp's result and
sl@0	816	* detach the PIDs (instead of waiting for them).
sl@0	817	*/
sl@0	818
sl@0	819	TclGetAndDetachPids(interp, chan);
sl@0	820	if (Tcl_Close(interp, chan) != TCL_OK) {
sl@0	821	return TCL_ERROR;
sl@0	822	}
sl@0	823	return TCL_OK;
sl@0	824	}
sl@0	825
sl@0	826	resultPtr = Tcl_NewObj();
sl@0	827	if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
sl@0	828	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
sl@0	829	Tcl_ResetResult(interp);
sl@0	830	Tcl_AppendResult(interp, "error reading output from command: ",
sl@0	831	Tcl_PosixError(interp), (char *) NULL);
sl@0	832	Tcl_DecrRefCount(resultPtr);
sl@0	833	return TCL_ERROR;
sl@0	834	}
sl@0	835	}
sl@0	836	/*
sl@0	837	* If the process produced anything on stderr, it will have been
sl@0	838	* returned in the interpreter result. It needs to be appended to
sl@0	839	* the result string.
sl@0	840	*/
sl@0	841
sl@0	842	result = Tcl_Close(interp, chan);
sl@0	843	string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
sl@0	844	Tcl_AppendToObj(resultPtr, string, length);
sl@0	845
sl@0	846	/*
sl@0	847	* If the last character of the result is a newline, then remove
sl@0	848	* the newline character.
sl@0	849	*/
sl@0	850
sl@0	851	if (keepNewline == 0) {
sl@0	852	string = Tcl_GetStringFromObj(resultPtr, &length);
sl@0	853	if ((length > 0) && (string[length - 1] == '\n')) {
sl@0	854	Tcl_SetObjLength(resultPtr, length - 1);
sl@0	855	}
sl@0	856	}
sl@0	857	Tcl_SetObjResult(interp, resultPtr);
sl@0	858
sl@0	859	return result;
sl@0	860	#endif /* !MAC_TCL */
sl@0	861	}
sl@0	862
sl@0	863	/*
sl@0	864	*---------------------------------------------------------------------------
sl@0	865	*
sl@0	866	* Tcl_FblockedObjCmd --
sl@0	867	*
sl@0	868	* This procedure is invoked to process the Tcl "fblocked" command.
sl@0	869	* See the user documentation for details on what it does.
sl@0	870	*
sl@0	871	* Results:
sl@0	872	* A standard Tcl result.
sl@0	873	*
sl@0	874	* Side effects:
sl@0	875	* Sets interp's result to boolean true or false depending on whether
sl@0	876	* the preceeding input operation on the channel would have blocked.
sl@0	877	*
sl@0	878	*---------------------------------------------------------------------------
sl@0	879	*/
sl@0	880
sl@0	881	/* ARGSUSED */
sl@0	882	int
sl@0	883	Tcl_FblockedObjCmd(unused, interp, objc, objv)
sl@0	884	ClientData unused; /* Not used. */
sl@0	885	Tcl_Interp interp; / Current interpreter. */
sl@0	886	int objc; /* Number of arguments. */
sl@0	887	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	888	{
sl@0	889	Tcl_Channel chan;
sl@0	890	int mode;
sl@0	891	char *arg;
sl@0	892
sl@0	893	if (objc != 2) {
sl@0	894	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
sl@0	895	return TCL_ERROR;
sl@0	896	}
sl@0	897
sl@0	898	arg = Tcl_GetString(objv[1]);
sl@0	899	chan = Tcl_GetChannel(interp, arg, &mode);
sl@0	900	if (chan == NULL) {
sl@0	901	return TCL_ERROR;
sl@0	902	}
sl@0	903	if ((mode & TCL_READABLE) == 0) {
sl@0	904	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
sl@0	905	arg, "\" wasn't opened for reading", (char *) NULL);
sl@0	906	return TCL_ERROR;
sl@0	907	}
sl@0	908
sl@0	909	Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan));
sl@0	910	return TCL_OK;
sl@0	911	}
sl@0	912
sl@0	913	/*
sl@0	914	*----------------------------------------------------------------------
sl@0	915	*
sl@0	916	* Tcl_OpenObjCmd --
sl@0	917	*
sl@0	918	* This procedure is invoked to process the "open" Tcl command.
sl@0	919	* See the user documentation for details on what it does.
sl@0	920	*
sl@0	921	* Results:
sl@0	922	* A standard Tcl result.
sl@0	923	*
sl@0	924	* Side effects:
sl@0	925	* See the user documentation.
sl@0	926	*
sl@0	927	*----------------------------------------------------------------------
sl@0	928	*/
sl@0	929
sl@0	930	/* ARGSUSED */
sl@0	931	int
sl@0	932	Tcl_OpenObjCmd(notUsed, interp, objc, objv)
sl@0	933	ClientData notUsed; /* Not used. */
sl@0	934	Tcl_Interp interp; / Current interpreter. */
sl@0	935	int objc; /* Number of arguments. */
sl@0	936	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	937	{
sl@0	938	int pipeline, prot;
sl@0	939	char modeString, what;
sl@0	940	Tcl_Channel chan;
sl@0	941
sl@0	942	if ((objc < 2) \|\| (objc > 4)) {
sl@0	943	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
sl@0	944	return TCL_ERROR;
sl@0	945	}
sl@0	946	prot = 0666;
sl@0	947	if (objc == 2) {
sl@0	948	modeString = "r";
sl@0	949	} else {
sl@0	950	modeString = Tcl_GetString(objv[2]);
sl@0	951	if (objc == 4) {
sl@0	952	if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
sl@0	953	return TCL_ERROR;
sl@0	954	}
sl@0	955	}
sl@0	956	}
sl@0	957
sl@0	958	pipeline = 0;
sl@0	959	what = Tcl_GetString(objv[1]);
sl@0	960	if (what[0] == '\|') {
sl@0	961	pipeline = 1;
sl@0	962	}
sl@0	963
sl@0	964	/*
sl@0	965	* Open the file or create a process pipeline.
sl@0	966	*/
sl@0	967
sl@0	968	if (!pipeline) {
sl@0	969	chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
sl@0	970	} else {
sl@0	971	#ifdef MAC_TCL
sl@0	972	Tcl_AppendResult(interp,
sl@0	973	"command pipelines not supported on Macintosh OS",
sl@0	974	(char *)NULL);
sl@0	975	return TCL_ERROR;
sl@0	976	#else
sl@0	977	int mode, seekFlag, cmdObjc;
sl@0	978	CONST char **cmdArgv;
sl@0	979
sl@0	980	if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
sl@0	981	return TCL_ERROR;
sl@0	982	}
sl@0	983
sl@0	984	mode = TclGetOpenMode(interp, modeString, &seekFlag);
sl@0	985	if (mode == -1) {
sl@0	986	chan = NULL;
sl@0	987	} else {
sl@0	988	int flags = TCL_STDERR \| TCL_ENFORCE_MODE;
sl@0	989	switch (mode & (O_RDONLY \| O_WRONLY \| O_RDWR)) {
sl@0	990	case O_RDONLY:
sl@0	991	flags \|= TCL_STDOUT;
sl@0	992	break;
sl@0	993	case O_WRONLY:
sl@0	994	flags \|= TCL_STDIN;
sl@0	995	break;
sl@0	996	case O_RDWR:
sl@0	997	flags \|= (TCL_STDIN \| TCL_STDOUT);
sl@0	998	break;
sl@0	999	default:
sl@0	1000	panic("Tcl_OpenCmd: invalid mode value");
sl@0	1001	break;
sl@0	1002	}
sl@0	1003	chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
sl@0	1004	}
sl@0	1005	ckfree((char *) cmdArgv);
sl@0	1006	#endif
sl@0	1007	}
sl@0	1008	if (chan == (Tcl_Channel) NULL) {
sl@0	1009	return TCL_ERROR;
sl@0	1010	}
sl@0	1011	Tcl_RegisterChannel(interp, chan);
sl@0	1012	Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
sl@0	1013	return TCL_OK;
sl@0	1014	}
sl@0	1015
sl@0	1016	/*
sl@0	1017	*----------------------------------------------------------------------
sl@0	1018	*
sl@0	1019	* TcpAcceptCallbacksDeleteProc --
sl@0	1020	*
sl@0	1021	* Assocdata cleanup routine called when an interpreter is being
sl@0	1022	* deleted to set the interp field of all the accept callback records
sl@0	1023	* registered with the interpreter to NULL. This will prevent the
sl@0	1024	* interpreter from being used in the future to eval accept scripts.
sl@0	1025	*
sl@0	1026	* Results:
sl@0	1027	* None.
sl@0	1028	*
sl@0	1029	* Side effects:
sl@0	1030	* Deallocates memory and sets the interp field of all the accept
sl@0	1031	* callback records to NULL to prevent this interpreter from being
sl@0	1032	* used subsequently to eval accept scripts.
sl@0	1033	*
sl@0	1034	*----------------------------------------------------------------------
sl@0	1035	*/
sl@0	1036
sl@0	1037	/* ARGSUSED */
sl@0	1038	static void
sl@0	1039	TcpAcceptCallbacksDeleteProc(clientData, interp)
sl@0	1040	ClientData clientData; /* Data which was passed when the assocdata
sl@0	1041	* was registered. */
sl@0	1042	Tcl_Interp interp; / Interpreter being deleted - not used. */
sl@0	1043	{
sl@0	1044	Tcl_HashTable *hTblPtr;
sl@0	1045	Tcl_HashEntry *hPtr;
sl@0	1046	Tcl_HashSearch hSearch;
sl@0	1047	AcceptCallback *acceptCallbackPtr;
sl@0	1048
sl@0	1049	hTblPtr = (Tcl_HashTable *) clientData;
sl@0	1050	for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
sl@0	1051	hPtr != (Tcl_HashEntry *) NULL;
sl@0	1052	hPtr = Tcl_NextHashEntry(&hSearch)) {
sl@0	1053	acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
sl@0	1054	acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
sl@0	1055	}
sl@0	1056	Tcl_DeleteHashTable(hTblPtr);
sl@0	1057	ckfree((char *) hTblPtr);
sl@0	1058	}
sl@0	1059
sl@0	1060	/*
sl@0	1061	*----------------------------------------------------------------------
sl@0	1062	*
sl@0	1063	* RegisterTcpServerInterpCleanup --
sl@0	1064	*
sl@0	1065	* Registers an accept callback record to have its interp
sl@0	1066	* field set to NULL when the interpreter is deleted.
sl@0	1067	*
sl@0	1068	* Results:
sl@0	1069	* None.
sl@0	1070	*
sl@0	1071	* Side effects:
sl@0	1072	* When, in the future, the interpreter is deleted, the interp
sl@0	1073	* field of the accept callback data structure will be set to
sl@0	1074	* NULL. This will prevent attempts to eval the accept script
sl@0	1075	* in a deleted interpreter.
sl@0	1076	*
sl@0	1077	*----------------------------------------------------------------------
sl@0	1078	*/
sl@0	1079
sl@0	1080	static void
sl@0	1081	RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
sl@0	1082	Tcl_Interp interp; / Interpreter for which we want to be
sl@0	1083	* informed of deletion. */
sl@0	1084	AcceptCallback *acceptCallbackPtr;
sl@0	1085	/* The accept callback record whose
sl@0	1086	* interp field we want set to NULL when
sl@0	1087	* the interpreter is deleted. */
sl@0	1088	{
sl@0	1089	Tcl_HashTable hTblPtr; / Hash table for accept callback
sl@0	1090	* records to smash when the interpreter
sl@0	1091	* will be deleted. */
sl@0	1092	Tcl_HashEntry hPtr; / Entry for this record. */
sl@0	1093	int new; /* Is the entry new? */
sl@0	1094
sl@0	1095	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
sl@0	1096	"tclTCPAcceptCallbacks",
sl@0	1097	NULL);
sl@0	1098	if (hTblPtr == (Tcl_HashTable *) NULL) {
sl@0	1099	hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
sl@0	1100	Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
sl@0	1101	(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
sl@0	1102	TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
sl@0	1103	}
sl@0	1104	hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
sl@0	1105	if (!new) {
sl@0	1106	panic("RegisterTcpServerCleanup: damaged accept record table");
sl@0	1107	}
sl@0	1108	Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
sl@0	1109	}
sl@0	1110
sl@0	1111	/*
sl@0	1112	*----------------------------------------------------------------------
sl@0	1113	*
sl@0	1114	* UnregisterTcpServerInterpCleanupProc --
sl@0	1115	*
sl@0	1116	* Unregister a previously registered accept callback record. The
sl@0	1117	* interp field of this record will no longer be set to NULL in
sl@0	1118	* the future when the interpreter is deleted.
sl@0	1119	*
sl@0	1120	* Results:
sl@0	1121	* None.
sl@0	1122	*
sl@0	1123	* Side effects:
sl@0	1124	* Prevents the interp field of the accept callback record from
sl@0	1125	* being set to NULL in the future when the interpreter is deleted.
sl@0	1126	*
sl@0	1127	*----------------------------------------------------------------------
sl@0	1128	*/
sl@0	1129
sl@0	1130	static void
sl@0	1131	UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
sl@0	1132	Tcl_Interp interp; / Interpreter in which the accept callback
sl@0	1133	* record was registered. */
sl@0	1134	AcceptCallback *acceptCallbackPtr;
sl@0	1135	/* The record for which to delete the
sl@0	1136	* registration. */
sl@0	1137	{
sl@0	1138	Tcl_HashTable *hTblPtr;
sl@0	1139	Tcl_HashEntry *hPtr;
sl@0	1140
sl@0	1141	hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
sl@0	1142	"tclTCPAcceptCallbacks", NULL);
sl@0	1143	if (hTblPtr == (Tcl_HashTable *) NULL) {
sl@0	1144	return;
sl@0	1145	}
sl@0	1146	hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
sl@0	1147	if (hPtr == (Tcl_HashEntry *) NULL) {
sl@0	1148	return;
sl@0	1149	}
sl@0	1150	Tcl_DeleteHashEntry(hPtr);
sl@0	1151	}
sl@0	1152
sl@0	1153	/*
sl@0	1154	*----------------------------------------------------------------------
sl@0	1155	*
sl@0	1156	* AcceptCallbackProc --
sl@0	1157	*
sl@0	1158	* This callback is invoked by the TCP channel driver when it
sl@0	1159	* accepts a new connection from a client on a server socket.
sl@0	1160	*
sl@0	1161	* Results:
sl@0	1162	* None.
sl@0	1163	*
sl@0	1164	* Side effects:
sl@0	1165	* Whatever the script does.
sl@0	1166	*
sl@0	1167	*----------------------------------------------------------------------
sl@0	1168	*/
sl@0	1169
sl@0	1170	static void
sl@0	1171	AcceptCallbackProc(callbackData, chan, address, port)
sl@0	1172	ClientData callbackData; /* The data stored when the callback
sl@0	1173	* was created in the call to
sl@0	1174	* Tcl_OpenTcpServer. */
sl@0	1175	Tcl_Channel chan; /* Channel for the newly accepted
sl@0	1176	* connection. */
sl@0	1177	char address; / Address of client that was
sl@0	1178	* accepted. */
sl@0	1179	int port; /* Port of client that was accepted. */
sl@0	1180	{
sl@0	1181	AcceptCallback *acceptCallbackPtr;
sl@0	1182	Tcl_Interp *interp;
sl@0	1183	char *script;
sl@0	1184	char portBuf[TCL_INTEGER_SPACE];
sl@0	1185	int result;
sl@0	1186
sl@0	1187	acceptCallbackPtr = (AcceptCallback *) callbackData;
sl@0	1188
sl@0	1189	/*
sl@0	1190	* Check if the callback is still valid; the interpreter may have gone
sl@0	1191	* away, this is signalled by setting the interp field of the callback
sl@0	1192	* data to NULL.
sl@0	1193	*/
sl@0	1194
sl@0	1195	if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
sl@0	1196
sl@0	1197	script = acceptCallbackPtr->script;
sl@0	1198	interp = acceptCallbackPtr->interp;
sl@0	1199
sl@0	1200	Tcl_Preserve((ClientData) script);
sl@0	1201	Tcl_Preserve((ClientData) interp);
sl@0	1202
sl@0	1203	TclFormatInt(portBuf, port);
sl@0	1204	Tcl_RegisterChannel(interp, chan);
sl@0	1205
sl@0	1206	/*
sl@0	1207	* Artificially bump the refcount to protect the channel from
sl@0	1208	* being deleted while the script is being evaluated.
sl@0	1209	*/
sl@0	1210
sl@0	1211	Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
sl@0	1212
sl@0	1213	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
sl@0	1214	" ", address, " ", portBuf, (char *) NULL);
sl@0	1215	if (result != TCL_OK) {
sl@0	1216	Tcl_BackgroundError(interp);
sl@0	1217	Tcl_UnregisterChannel(interp, chan);
sl@0	1218	}
sl@0	1219
sl@0	1220	/*
sl@0	1221	* Decrement the artificially bumped refcount. After this it is
sl@0	1222	* not safe anymore to use "chan", because it may now be deleted.
sl@0	1223	*/
sl@0	1224
sl@0	1225	Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
sl@0	1226
sl@0	1227	Tcl_Release((ClientData) interp);
sl@0	1228	Tcl_Release((ClientData) script);
sl@0	1229	} else {
sl@0	1230
sl@0	1231	/*
sl@0	1232	* The interpreter has been deleted, so there is no useful
sl@0	1233	* way to utilize the client socket - just close it.
sl@0	1234	*/
sl@0	1235
sl@0	1236	Tcl_Close((Tcl_Interp *) NULL, chan);
sl@0	1237	}
sl@0	1238	}
sl@0	1239
sl@0	1240	/*
sl@0	1241	*----------------------------------------------------------------------
sl@0	1242	*
sl@0	1243	* TcpServerCloseProc --
sl@0	1244	*
sl@0	1245	* This callback is called when the TCP server channel for which it
sl@0	1246	* was registered is being closed. It informs the interpreter in
sl@0	1247	* which the accept script is evaluated (if that interpreter still
sl@0	1248	* exists) that this channel no longer needs to be informed if the
sl@0	1249	* interpreter is deleted.
sl@0	1250	*
sl@0	1251	* Results:
sl@0	1252	* None.
sl@0	1253	*
sl@0	1254	* Side effects:
sl@0	1255	* In the future, if the interpreter is deleted this channel will
sl@0	1256	* no longer be informed.
sl@0	1257	*
sl@0	1258	*----------------------------------------------------------------------
sl@0	1259	*/
sl@0	1260
sl@0	1261	static void
sl@0	1262	TcpServerCloseProc(callbackData)
sl@0	1263	ClientData callbackData; /* The data passed in the call to
sl@0	1264	* Tcl_CreateCloseHandler. */
sl@0	1265	{
sl@0	1266	AcceptCallback *acceptCallbackPtr;
sl@0	1267	/* The actual data. */
sl@0	1268
sl@0	1269	acceptCallbackPtr = (AcceptCallback *) callbackData;
sl@0	1270	if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
sl@0	1271	UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
sl@0	1272	acceptCallbackPtr);
sl@0	1273	}
sl@0	1274	Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
sl@0	1275	ckfree((char *) acceptCallbackPtr);
sl@0	1276	}
sl@0	1277
sl@0	1278	/*
sl@0	1279	*----------------------------------------------------------------------
sl@0	1280	*
sl@0	1281	* Tcl_SocketObjCmd --
sl@0	1282	*
sl@0	1283	* This procedure is invoked to process the "socket" Tcl command.
sl@0	1284	* See the user documentation for details on what it does.
sl@0	1285	*
sl@0	1286	* Results:
sl@0	1287	* A standard Tcl result.
sl@0	1288	*
sl@0	1289	* Side effects:
sl@0	1290	* Creates a socket based channel.
sl@0	1291	*
sl@0	1292	*----------------------------------------------------------------------
sl@0	1293	*/
sl@0	1294
sl@0	1295	int
sl@0	1296	Tcl_SocketObjCmd(notUsed, interp, objc, objv)
sl@0	1297	ClientData notUsed; /* Not used. */
sl@0	1298	Tcl_Interp interp; / Current interpreter. */
sl@0	1299	int objc; /* Number of arguments. */
sl@0	1300	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1301	{
sl@0	1302	static CONST char *socketOptions[] = {
sl@0	1303	"-async", "-myaddr", "-myport","-server", (char *) NULL
sl@0	1304	};
sl@0	1305	enum socketOptions {
sl@0	1306	SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
sl@0	1307	};
sl@0	1308	int optionIndex, a, server, port;
sl@0	1309	char arg, copyScript, host, script;
sl@0	1310	char *myaddr = NULL;
sl@0	1311	int myport = 0;
sl@0	1312	int async = 0;
sl@0	1313	Tcl_Channel chan;
sl@0	1314	AcceptCallback *acceptCallbackPtr;
sl@0	1315
sl@0	1316	server = 0;
sl@0	1317	script = NULL;
sl@0	1318
sl@0	1319	if (TclpHasSockets(interp) != TCL_OK) {
sl@0	1320	return TCL_ERROR;
sl@0	1321	}
sl@0	1322
sl@0	1323	for (a = 1; a < objc; a++) {
sl@0	1324	arg = Tcl_GetString(objv[a]);
sl@0	1325	if (arg[0] != '-') {
sl@0	1326	break;
sl@0	1327	}
sl@0	1328	if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
sl@0	1329	"option", TCL_EXACT, &optionIndex) != TCL_OK) {
sl@0	1330	return TCL_ERROR;
sl@0	1331	}
sl@0	1332	switch ((enum socketOptions) optionIndex) {
sl@0	1333	case SKT_ASYNC: {
sl@0	1334	if (server == 1) {
sl@0	1335	Tcl_AppendResult(interp,
sl@0	1336	"cannot set -async option for server sockets",
sl@0	1337	(char *) NULL);
sl@0	1338	return TCL_ERROR;
sl@0	1339	}
sl@0	1340	async = 1;
sl@0	1341	break;
sl@0	1342	}
sl@0	1343	case SKT_MYADDR: {
sl@0	1344	a++;
sl@0	1345	if (a >= objc) {
sl@0	1346	Tcl_AppendResult(interp,
sl@0	1347	"no argument given for -myaddr option",
sl@0	1348	(char *) NULL);
sl@0	1349	return TCL_ERROR;
sl@0	1350	}
sl@0	1351	myaddr = Tcl_GetString(objv[a]);
sl@0	1352	break;
sl@0	1353	}
sl@0	1354	case SKT_MYPORT: {
sl@0	1355	char *myPortName;
sl@0	1356	a++;
sl@0	1357	if (a >= objc) {
sl@0	1358	Tcl_AppendResult(interp,
sl@0	1359	"no argument given for -myport option",
sl@0	1360	(char *) NULL);
sl@0	1361	return TCL_ERROR;
sl@0	1362	}
sl@0	1363	myPortName = Tcl_GetString(objv[a]);
sl@0	1364	if (TclSockGetPort(interp, myPortName, "tcp", &myport)
sl@0	1365	!= TCL_OK) {
sl@0	1366	return TCL_ERROR;
sl@0	1367	}
sl@0	1368	break;
sl@0	1369	}
sl@0	1370	case SKT_SERVER: {
sl@0	1371	if (async == 1) {
sl@0	1372	Tcl_AppendResult(interp,
sl@0	1373	"cannot set -async option for server sockets",
sl@0	1374	(char *) NULL);
sl@0	1375	return TCL_ERROR;
sl@0	1376	}
sl@0	1377	server = 1;
sl@0	1378	a++;
sl@0	1379	if (a >= objc) {
sl@0	1380	Tcl_AppendResult(interp,
sl@0	1381	"no argument given for -server option",
sl@0	1382	(char *) NULL);
sl@0	1383	return TCL_ERROR;
sl@0	1384	}
sl@0	1385	script = Tcl_GetString(objv[a]);
sl@0	1386	break;
sl@0	1387	}
sl@0	1388	default: {
sl@0	1389	panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
sl@0	1390	}
sl@0	1391	}
sl@0	1392	}
sl@0	1393	if (server) {
sl@0	1394	host = myaddr; /* NULL implies INADDR_ANY */
sl@0	1395	if (myport != 0) {
sl@0	1396	Tcl_AppendResult(interp, "Option -myport is not valid for servers",
sl@0	1397	NULL);
sl@0	1398	return TCL_ERROR;
sl@0	1399	}
sl@0	1400	} else if (a < objc) {
sl@0	1401	host = Tcl_GetString(objv[a]);
sl@0	1402	a++;
sl@0	1403	} else {
sl@0	1404	wrongNumArgs:
sl@0	1405	Tcl_AppendResult(interp, "wrong # args: should be either:\n",
sl@0	1406	Tcl_GetString(objv[0]),
sl@0	1407	" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
sl@0	1408	Tcl_GetString(objv[0]),
sl@0	1409	" -server command ?-myaddr addr? port",
sl@0	1410	(char *) NULL);
sl@0	1411	return TCL_ERROR;
sl@0	1412	}
sl@0	1413
sl@0	1414	if (a == objc-1) {
sl@0	1415	if (TclSockGetPort(interp, Tcl_GetString(objv[a]),
sl@0	1416	"tcp", &port) != TCL_OK) {
sl@0	1417	return TCL_ERROR;
sl@0	1418	}
sl@0	1419	} else {
sl@0	1420	goto wrongNumArgs;
sl@0	1421	}
sl@0	1422
sl@0	1423	if (server) {
sl@0	1424	acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
sl@0	1425	sizeof(AcceptCallback));
sl@0	1426	copyScript = ckalloc((unsigned) strlen(script) + 1);
sl@0	1427	strcpy(copyScript, script);
sl@0	1428	acceptCallbackPtr->script = copyScript;
sl@0	1429	acceptCallbackPtr->interp = interp;
sl@0	1430	chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
sl@0	1431	(ClientData) acceptCallbackPtr);
sl@0	1432	if (chan == (Tcl_Channel) NULL) {
sl@0	1433	ckfree(copyScript);
sl@0	1434	ckfree((char *) acceptCallbackPtr);
sl@0	1435	return TCL_ERROR;
sl@0	1436	}
sl@0	1437
sl@0	1438	/*
sl@0	1439	* Register with the interpreter to let us know when the
sl@0	1440	* interpreter is deleted (by having the callback set the
sl@0	1441	* acceptCallbackPtr->interp field to NULL). This is to
sl@0	1442	* avoid trying to eval the script in a deleted interpreter.
sl@0	1443	*/
sl@0	1444
sl@0	1445	RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
sl@0	1446
sl@0	1447	/*
sl@0	1448	* Register a close callback. This callback will inform the
sl@0	1449	* interpreter (if it still exists) that this channel does not
sl@0	1450	* need to be informed when the interpreter is deleted.
sl@0	1451	*/
sl@0	1452
sl@0	1453	Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
sl@0	1454	(ClientData) acceptCallbackPtr);
sl@0	1455	} else {
sl@0	1456	chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
sl@0	1457	if (chan == (Tcl_Channel) NULL) {
sl@0	1458	return TCL_ERROR;
sl@0	1459	}
sl@0	1460	}
sl@0	1461	Tcl_RegisterChannel(interp, chan);
sl@0	1462	Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
sl@0	1463
sl@0	1464	return TCL_OK;
sl@0	1465	}
sl@0	1466
sl@0	1467	/*
sl@0	1468	*----------------------------------------------------------------------
sl@0	1469	*
sl@0	1470	* Tcl_FcopyObjCmd --
sl@0	1471	*
sl@0	1472	* This procedure is invoked to process the "fcopy" Tcl command.
sl@0	1473	* See the user documentation for details on what it does.
sl@0	1474	*
sl@0	1475	* Results:
sl@0	1476	* A standard Tcl result.
sl@0	1477	*
sl@0	1478	* Side effects:
sl@0	1479	* Moves data between two channels and possibly sets up a
sl@0	1480	* background copy handler.
sl@0	1481	*
sl@0	1482	*----------------------------------------------------------------------
sl@0	1483	*/
sl@0	1484
sl@0	1485	int
sl@0	1486	Tcl_FcopyObjCmd(dummy, interp, objc, objv)
sl@0	1487	ClientData dummy; /* Not used. */
sl@0	1488	Tcl_Interp interp; / Current interpreter. */
sl@0	1489	int objc; /* Number of arguments. */
sl@0	1490	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	1491	{
sl@0	1492	Tcl_Channel inChan, outChan;
sl@0	1493	char *arg;
sl@0	1494	int mode, i;
sl@0	1495	int toRead, index;
sl@0	1496	Tcl_Obj *cmdPtr;
sl@0	1497	static CONST char* switches[] = { "-size", "-command", NULL };
sl@0	1498	enum { FcopySize, FcopyCommand };
sl@0	1499
sl@0	1500	if ((objc < 3) \|\| (objc > 7) \|\| (objc == 4) \|\| (objc == 6)) {
sl@0	1501	Tcl_WrongNumArgs(interp, 1, objv,
sl@0	1502	"input output ?-size size? ?-command callback?");
sl@0	1503	return TCL_ERROR;
sl@0	1504	}
sl@0	1505
sl@0	1506	/*
sl@0	1507	* Parse the channel arguments and verify that they are readable
sl@0	1508	* or writable, as appropriate.
sl@0	1509	*/
sl@0	1510
sl@0	1511	arg = Tcl_GetString(objv[1]);
sl@0	1512	inChan = Tcl_GetChannel(interp, arg, &mode);
sl@0	1513	if (inChan == (Tcl_Channel) NULL) {
sl@0	1514	return TCL_ERROR;
sl@0	1515	}
sl@0	1516	if ((mode & TCL_READABLE) == 0) {
sl@0	1517	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
sl@0	1518	arg,
sl@0	1519	"\" wasn't opened for reading", (char *) NULL);
sl@0	1520	return TCL_ERROR;
sl@0	1521	}
sl@0	1522	arg = Tcl_GetString(objv[2]);
sl@0	1523	outChan = Tcl_GetChannel(interp, arg, &mode);
sl@0	1524	if (outChan == (Tcl_Channel) NULL) {
sl@0	1525	return TCL_ERROR;
sl@0	1526	}
sl@0	1527	if ((mode & TCL_WRITABLE) == 0) {
sl@0	1528	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
sl@0	1529	arg,
sl@0	1530	"\" wasn't opened for writing", (char *) NULL);
sl@0	1531	return TCL_ERROR;
sl@0	1532	}
sl@0	1533
sl@0	1534	toRead = -1;
sl@0	1535	cmdPtr = NULL;
sl@0	1536	for (i = 3; i < objc; i += 2) {
sl@0	1537	if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
sl@0	1538	(int *) &index) != TCL_OK) {
sl@0	1539	return TCL_ERROR;
sl@0	1540	}
sl@0	1541	switch (index) {
sl@0	1542	case FcopySize:
sl@0	1543	if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
sl@0	1544	return TCL_ERROR;
sl@0	1545	}
sl@0	1546	break;
sl@0	1547	case FcopyCommand:
sl@0	1548	cmdPtr = objv[i+1];
sl@0	1549	break;
sl@0	1550	}
sl@0	1551	}
sl@0	1552
sl@0	1553	return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
sl@0	1554	}

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