![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tktcp.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tk|
Return to tktcp.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tk |
1.1 root 1: /* tkTCP.c --
2: *
3: * This file provides basic capabilities to establish a server,
4: * attached to a TCP/IP port, that attaches to a Tcl interpreter.
5: * Such servers provide a remote-procedure-call mechanism for Tcl
6: * without needing to resort to Tk's X-window-based complexities, and
7: * also allow access to services that are not bound to any particular
8: * display.
9: */
10:
11: static char RCSid [] =
12: "$Header: /cluster21/kennykb/src/tclTCP.1.0beta/RCS/tclTCP.c,v 1.7 1992/05/05 18:31:13 kennykb Exp kennykb $";
13: /* $Source: /cluster21/kennykb/src/tclTCP.1.0beta/RCS/tclTCP.c,v $
14: * $Log: tclTCP.c,v $
15: * Revision 1.7 1992/05/05 18:31:13 kennykb
16: * Changed the flow through the `delete server' code to make it work even
17: * if a server is deleted while a client is active.
18: * The change avoids aborts at termination time if the server delete code
19: * is reached before the application exits.
20: *
21: * Revision 1.6 1992/03/04 20:04:00 kennykb
22: * Modified source code to use the Tcl configurator and corresponding include
23: * files.
24: *
25: * Revision 1.5 1992/02/25 15:21:30 kennykb
26: * Modifications to quiet warnings from gcc
27: * ,
28: *
29: * Revision 1.4 1992/02/24 19:30:30 kennykb
30: * Merged branches (a) updated tcpTrustedHost and (b) broken-out event mgr.
31: *
32: * Revision 1.3 1992/02/20 16:22:53 kennykb
33: * Event management code removed and broken out into a separate file,
34: * simpleEvent.c
35: *
36: * Revision 1.2.1.1 1992/02/24 19:12:30 kennykb
37: * Rewrote tcpTrustedHost to be more forgiving of unusual configurations.
38: * It now looks through all aliases for the local host and the loopback
39: * pseudo-host.
40: *
41: * Revision 1.2 1992/02/18 14:43:21 kennykb
42: * Fix for bug 920218.1 in `History' file.
43: *
44: * Revision 1.1 1992/02/14 19:57:51 kennykb
45: * Initial revision
46: *
47: */
48:
49: static char copyright [] =
50: "Copyright (C) 1992 General Electric. All rights reserved." ;
51:
52: /*
53: * Permission to use, copy, modify, and distribute this
54: * software and its documentation for any purpose and without
55: * fee is hereby granted, provided that the above copyright
56: * notice appear in all copies and that both that copyright
57: * notice and this permission notice appear in supporting
58: * documentation, and that the name of General Electric not be used in
59: * advertising or publicity pertaining to distribution of the
60: * software without specific, written prior permission.
61: * General Electric makes no representations about the suitability of
62: * this software for any purpose. It is provided "as is"
63: * without express or implied warranty.
64: *
65: * This work was supported by the DARPA Initiative in Concurrent
66: * Engineering (DICE) through DARPA Contract MDA972-88-C-0047.
67: */
68:
69: #include <errno.h>
70: #include <sys/types.h>
71: #include <sys/ioctl.h>
72: #include <sys/socket.h>
73: #include <netinet/in.h>
74: #include <netdb.h>
75: #include <arpa/inet.h>
76:
77: /* Only some copies of netinet/in.h have the following defined. */
78:
79: #ifndef INADDR_LOOPBACK
80: #ifdef __STDC__
81: #define INADDR_LOOPBACK 0x7f000001UL
82: #else
83: #define INADDR_LOOPBACK (unsigned long) 0x7f000001L
84: #endif /* __STDC__ */
85: #endif /* INADDR_LOOPBACK */
86:
87: #include <signal.h>
88:
89: #include <tclInt.h>
90: #include <tclUnix.h>
91: #include <tk.h>
92: #include "tkTCP.h"
93:
94: /* Kernel calls */
95:
96: /* There doesn't seem to be any place to get these....
97: * certainly not a portable one.
98: */
99:
100: extern int accept _ANSI_ARGS_((int, struct sockaddr *, int *));
101: extern int bind _ANSI_ARGS_((int, const struct sockaddr *, int));
102: extern int close _ANSI_ARGS_((int));
103: extern int connect _ANSI_ARGS_((int, const struct sockaddr *, int));
104: extern int gethostname _ANSI_ARGS_((char *, int));
105: extern int getsockname _ANSI_ARGS_((int, struct sockaddr *, int *));
106: extern int ioctl _ANSI_ARGS_((int, int, char *));
107: extern int listen _ANSI_ARGS_((int, int));
108: extern int read _ANSI_ARGS_((int, char *, int));
109: extern int select _ANSI_ARGS_((int, fd_set *, fd_set *, fd_set *,
110: struct timeval *));
111: extern int socket _ANSI_ARGS_((int, int, int));
112: extern int getdtablesize _ANSI_ARGS_((void));
113:
114:
115: /* Configuration parameters */
116:
117: /*
118: * TCP_LISTEN_BACKLOG gives the maximum backlog of connection requests
119: * that may be queued for any server
120: */
121:
122: #define TCP_LISTEN_BACKLOG 3
123:
124: /* Internal data structures */
125:
126: /*
127: * For each server that is established in any interpreter, there's a
128: * record of the following type. Note that only one server may be
129: * running at a time in any interpreter, unless the Tk services are
130: * available for event management.
131: */
132:
133: typedef struct tcp_ServerData {
134: Tcl_Interp * interp; /* Interpreter in which connections */
135: /* are processed. */
136: char name[ 16 ];
137: /* Name of the server object. */
138: int socketfd;
139: /* Filedescriptor of the socket at */
140: /* which the server listens for connections */
141: char * command;
142: /* Command to be executed (using */
143: /* Tcl_Eval) when a connection request */
144: /* arrives. */
145: Tcl_FreeProc * freeCommand;
146: /* Procedure to free the command when */
147: /* it's no longer needed. */
148: int stopFlag;
149: /* Flag == TRUE if the server is trying */
150: /* to shut down. */
151: int raw; /* Flag == TRUE if for raw socket mode. */
152: struct tcp_ClientData * firstClient;
153: /* First in the list of clients at this */
154: /* server */
155: struct tcp_ServerData * next, * prev;
156: /* Linkage in the list of all active servers */
157: } Tcp_ServerData;
158:
159: /*
160: * Each client of a server will have a record of the following type.
161: */
162:
163: typedef struct tcp_ClientData {
164: struct tcp_ServerData * server;
165: /* Server to which the client belongs */
166: char name [16];
167: /* Name of the client */
168: int socketfd;
169: /* Filedescriptor of the socket of the */
170: /* the client's connection. */
171: struct sockaddr_in peeraddr;
172: /* IP address from which the client */
173: /* established the connection. */
174: char * command;
175: /* Command to execute when the client */
176: /* sends a message */
177: Tcl_FreeProc * freeCommand;
178: /* Procedure to free the command when it's */
179: /* no longer needed */
180: Tcl_CmdBuf inputBuffer;
181: /* Buffer where client commands are stored */
182: char * resultString;
183: /* Result of executing a command on the */
184: /* client */
185: char * resultPointer;
186: /* Pointer to the portion of resultString */
187: /* that remains to be transmitted back */
188: /* to the client */
189: Tcl_FreeProc * freeResultString;
190: /* Procedure to free the result string when */
191: /* it's no longer needed. */
192: int activeFlag;
193: /* Flag == 1 iff a command is pending on */
194: /* this client. */
195: int closeFlag;
196: /* Flag == 1 if the client should be closed */
197: /* once its result has been returned. */
198: struct tcp_ClientData *next, *prev;
199: /* Next and previous entries in the list of */
200: /* clients at this server */
201: } Tcp_ClientData;
202:
203: /* Static variables in this file */
204:
205: static char * tcpCurrentClient = NULL;
206: /* The name of the client for which a */
207: /* command is being processed. */
208: static Tcp_ServerData * tcpFirstServer = NULL;
209: /* Pointer to the first in a list of */
210: /* servers active in the current process. */
211:
212: /* Declarations for static functions within this file. */
213:
214: /* Static procedures in this file */
215:
216: static void simpleDeleteFileHandler1 _ANSI_ARGS_((ClientData, int));
217:
218: static void simpleDeleteFileHandler2 _ANSI_ARGS_((ClientData));
219:
220: static int
221: tcpClientCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
222: int argc, char * * argv));
223:
224: static int
225: tcpConnectCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
226: int argc, char * * argv));
227:
228: static int
229: tcpEvalCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
230: int argc, char * * argv));
231:
232: static int
233: tcpLoginCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
234: int argc, char * * argv));
235:
236: static int
237: tcpMainLoopCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
238: int argc, char * * argv));
239:
240: static int
241: tcpPollCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
242: int argc, char * * argv));
243:
244: static int
245: tcpServerCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
246: int argc, char * * argv));
247:
248: static int
249: tcpServersCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
250: int argc, char * * argv));
251: static int
252: tcpWaitCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
253: int argc, char * * argv));
254:
255: static int
256: tcpServerObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
257: int argc, char * * argv));
258: static void
259: deleteTcpServerObjectCmd _ANSI_ARGS_((ClientData clientData));
260:
261: static int
262: tcpServerObjectAcceptCmd _ANSI_ARGS_((ClientData clientData,
263: Tcl_Interp * interp, int argc,
264: char * * argv));
265:
266: static int
267: tcpServerObjectClientsCmd _ANSI_ARGS_((ClientData clientData,
268: Tcl_Interp * interp, int argc,
269: char * * argv));
270:
271: static int
272: tcpServerObjectConfigCmd _ANSI_ARGS_((ClientData clientData,
273: Tcl_Interp * interp, int argc,
274: char * * argv));
275:
276: static int
277: tcpServerObjectStartCmd _ANSI_ARGS_((ClientData clientData,
278: Tcl_Interp * interp, int argc,
279: char * * argv));
280:
281: static int
282: tcpServerObjectStopCmd _ANSI_ARGS_((ClientData clientData,
283: Tcl_Interp * interp, int argc,
284: char * * argv));
285:
286: static void
287: tcpDeleteServer _ANSI_ARGS_((Tcp_ServerData * server));
288:
289: static int
290: tcpServerObjectConfig _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
291: int argc, char * * argv));
292:
293: static int
294: tcpClientObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
295: int argc, char * * argv));
296:
297: static int
298: tcpClientObjectCloseCmd _ANSI_ARGS_((ClientData clientData,
299: Tcl_Interp * interp,
300: int argc, char * * argv));
301:
302: static int
303: tcpClientObjectCommandCmd _ANSI_ARGS_((ClientData clientData,
304: Tcl_Interp * interp,
305: int argc, char * * argv));
306:
307: static int
308: tcpClientObjectDoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
309: int argc, char * * argv));
310:
311: static int
312: tcpClientObjectHostnameCmd _ANSI_ARGS_((ClientData clientData,
313: Tcl_Interp * interp,
314: int argc, char * * argv));
315:
316: static int
317: tcpClientObjectServerCmd _ANSI_ARGS_((ClientData clientData,
318: Tcl_Interp * interp,
319: int argc, char * * argv));
320:
321: static void
322: deleteTcpClientObjectCmd _ANSI_ARGS_((ClientData clientData));
323:
324: static int
325: tcpConnectionObjectCmd _ANSI_ARGS_((ClientData clientData,
326: Tcl_Interp * interp,
327: int argc, char * * argv));
328:
329: static int
330: tcpConnectionObjectCloseCmd _ANSI_ARGS_((ClientData clientData,
331: Tcl_Interp * interp,
332: int argc, char * * argv));
333:
334: static int
335: tcpConnectionObjectSendCmd _ANSI_ARGS_((ClientData clientData,
336: Tcl_Interp * interp,
337: int argc, char * * argv));
338:
339: static void
340: deleteTcpConnectionObjectCmd _ANSI_ARGS_((ClientData clientData));
341:
342: static void
343: tcpServerAcceptConnection _ANSI_ARGS_((ClientData clientData, int mask));
344:
345: static void
346: tcpReturnResultToClient _ANSI_ARGS_((Tcp_ClientData * client,
347: Tcl_Interp * interp,
348: int status, int closeflag));
349:
350: static void
351: tcpWriteResultToClient _ANSI_ARGS_((ClientData clientData, int mask));
352:
353: static void
354: tcpClientReadError _ANSI_ARGS_((Tcp_ClientData * client));
355:
356: static void
357: tcpClientWriteError _ANSI_ARGS_((Tcp_ClientData * client));
358:
359: static void
360: tcpPrepareClientForInput _ANSI_ARGS_((Tcp_ClientData * client));
361:
362: static void
363: tcpReceiveClientInput _ANSI_ARGS_((ClientData clientData, int mask));
364:
365: static void
366: tcpCloseClient _ANSI_ARGS_((Tcp_ClientData * client));
367:
368: static int
369: tcpTrustedHost _ANSI_ARGS_((char * hostname));
370:
371: static int
372: tcpSendCmdToServer _ANSI_ARGS_((Tcl_Interp * interp, int s, char * message));
373:
374: static int
375: tcpReceiveResultFromServer _ANSI_ARGS_((Tcl_Interp * interp, int s));
376:
377: /*
378: * simpleReportBackgroundError --
379: *
380: * This procedure is invoked to report a Tcl error in the background,
381: * when TCL_ERROR has been passed out to the outermost level.
382: *
383: * It tries to run `bgerror' giving it the error message. If this
384: * fails, it reports the problem on stderr.
385: */
386:
387: void
388: simpleReportBackgroundError (interp)
389: Tcl_Interp * interp;
390: {
391:
392: char *argv[2];
393: char *command;
394: char *error;
395: char *errorInfo, *tmp;
396: int status;
397: int unixStatus;
398:
399: /* Get the error message out of the interpreter. */
400:
401: error = (char *) ckalloc (strlen (interp -> result) + 1);
402: strcpy (error, interp -> result);
403:
404: /* Get errorInfo, too */
405:
406: tmp = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
407: if (tmp == NULL) {
408: errorInfo = error;
409: } else {
410: errorInfo = (char *) ckalloc (strlen (tmp) + 1);
411: strcpy (errorInfo, tmp);
412: }
413:
414: /* Build a `bgerror' command to report the error */
415:
416: argv[0] = "bgerror";
417: argv[1] = error;
418: command = Tcl_Merge (2, argv);
419:
420: /* Try to run the command */
421:
422: status = Tcl_Eval (interp, command, 0, (char **) NULL);
423:
424: if (status != TCL_OK) {
425:
426: /* Command failed. Report the problem to stderr. */
427:
428: tmp = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
429: if (tmp == NULL) {
430: tmp = interp -> result;
431: }
432: unixStatus = fprintf (stderr, "\n\
433: ------------------------------------------------------------------------\n\
434: Tcl interpreter detected a background error.\n\
435: Original error:\n\
436: %s\n\
437: \n\
438: User \"bgerror\" procedure failed to handle the background error.\n\
439: Error in bgerror:\n\
440: %s\n",
441: errorInfo, tmp);
442: if (unixStatus < 0) {
443: abort ();
444: }
445: }
446:
447: Tcl_ResetResult (interp);
448:
449: free (command);
450:
451: ckfree (error);
452:
453: if (errorInfo != error) {
454: ckfree (errorInfo);
455: }
456: }
457:
458: /*
459: * simpleCreateFileHandler --
460: *
461: * This procedure is invoked to create a handle to cause a callback
462: * whenever a condition (readable, writable, exception) is
463: * present on a given file.
464: *
465: * In the Tk environment, the file handler is created using Tk's
466: * Tk_CreateFileHandler procedure, and the callback takes place
467: * from the Tk main loop. In a non-Tk environment, a
468: * Tcp_FileHandler structure is created to describe the file, and
469: * this structure is linked to a chain of such structures
470: * processed by the server main loop.
471: */
472:
473: void
474: simpleCreateFileHandler (fd, mask, proc, clientData)
475: int fd;
476: int mask;
477: Tk_FileProc * proc;
478: ClientData clientData;
479: {
480: Tk_CreateFileHandler (fd, mask, (Tk_FileProc *) proc, clientData);
481:
482: /* It is possible that we have a file handler scheduled for deletion.
483: * This deletion has to be cancelled if we've requested creation of
484: * another one.
485: */
486:
487: Tk_CancelIdleCall ((Tk_IdleProc *) simpleDeleteFileHandler2,
488: (ClientData) fd);
489: }
490:
491: /*
492: * simpleDeleteFileHandler --
493: *
494: * This function is invoked when the program is no longer interested in
495: * handling events on a file. It removes any outstanding handler on the file.
496: *
497: * The function is a little tricky because a file handler on the file may
498: * be active. In a non-Tk environment, this is simple; the SIMPLE_DELETE flag
499: * is set in the handler's mask, and the main loop deletes the handler once
500: * it is quiescent. In Tk, the event loop won't do that, so what we do
501: * is set a DoWhenIdle to delete the handler and return. The DoWhenIdle
502: * gets called back from the Tk event loop at a time that the handler is
503: * quiescent, and deletes the handler.
504: */
505:
506: void
507: simpleDeleteFileHandler (fd)
508: int fd;
509: {
510: /* First of all, we have to zero the file's mask to avoid calling the same
511: handler over again if the file is still ready. */
512: Tk_CreateFileHandler (fd, 0, (Tk_FileProc *) simpleDeleteFileHandler1,
513: (ClientData) NULL);
514: Tk_DoWhenIdle ((Tk_IdleProc *) simpleDeleteFileHandler2,
515: (ClientData) fd);
516: }
517:
518:
519: /* ARGSUSED */
520: static void
521: simpleDeleteFileHandler1 (clientData, mask)
522: ClientData clientData;
523: int mask;
524: {
525: (void) fprintf (stderr, "in simpleDeleteFileHandler1: bug in tkEvent.c");
526: abort ();
527: }
528:
529: static void
530: simpleDeleteFileHandler2 (clientData)
531: ClientData clientData;
532: {
533: int fd = (int) clientData;
534:
535: Tk_DeleteFileHandler (fd);
536: }
537:
538: /*
539: *----------------------------------------------------------------------
540: * Tk_TcpCmd:
541: *
542: * This procedure implements a `tcp' command for Tcl. It provides the
543: * top-level actions for TCP/IP connections.
544: *
545: * This command is divided into variants, each with its own procedure:
546: *
547: * tcp client
548: * Returns the current active client, or an error if there is
549: * none.
550: * tcp connect host port
551: * Establish a connection to a server running at `port' on
552: * `host.'
553: * tcp eval client command
554: * Do default command processing for command "$command",
555: * originating at client "$client".
556: * tcp login client
557: * Do default login processing for $client.
558: * tcp mainloop
559: * Start the main loop for a server or group of servers.
560: * tcp poll
561: * Poll for whether servers have work to do.
562: * tcp servers
563: * Returns a list of the currently active servers.
564: * tcp server ?args?
565: * Set up a server to run in the current interpreter.
566: * tcp wait
567: * Wait for a server to have work to do.
568: *----------------------------------------------------------------------
569: */
570:
571: int
572: Tk_TcpCmd (clientData, interp, argc, argv)
573: ClientData clientData;
574: Tcl_Interp * interp;
575: int argc;
576: char * * argv;
577: {
578: char c;
579: unsigned length;
580:
581: if (argc < 2) {
582: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [0],
583: " command ?args?\"", (char *) NULL);
584: return TCL_ERROR;
585: }
586:
587: c = argv [1] [0];
588: length = strlen (argv [1]);
589:
590: if ((c == 'c') && (length >= 2) &&
591: (strncmp (argv [1], "client", length) == 0)) {
592: return tcpClientCommand (clientData, interp, argc-1, argv+1);
593: }
594: if ((c == 'c') && (length >= 2) &&
595: (strncmp (argv [1], "connect", length) == 0)) {
596: return tcpConnectCommand (clientData, interp, argc-1, argv+1);
597: }
598: if ((c == 'e') && (strncmp (argv [1], "eval", length) == 0)) {
599: return tcpEvalCommand (clientData, interp, argc-1, argv+1);
600: }
601: if ((c == 'l') && (strncmp (argv [1], "login", length) == 0)) {
602: return tcpLoginCommand (clientData, interp, argc-1, argv+1);
603: }
604: if ((c == 'm') && (strncmp (argv [1], "mainloop", length) == 0)) {
605: return tcpMainLoopCommand (clientData, interp, argc-1, argv+1);
606: }
607: if ((c == 'p') && (strncmp (argv [1], "poll", length) == 0)) {
608: return tcpPollCommand (clientData, interp, argc-1, argv+1);
609: }
610: if ((c == 's') && (length >= 7)
611: && (strncmp (argv [1], "servers", length) == 0)) {
612: return tcpServersCommand (clientData, interp, argc-1, argv+1);
613: }
614: if ((c == 's') && (strncmp (argv [1], "server", length) == 0)) {
615: return tcpServerCommand (clientData, interp, argc-1, argv+1);
616: }
617: if ((c == 'w') && (strncmp (argv [1], "wait", length) == 0)) {
618: return tcpWaitCommand (clientData, interp, argc-1, argv+1);
619: }
620: Tcl_AppendResult (interp, "bad option \"", argv [1],
621: "\": should be client, eval, login,",
622: " mainloop, poll, servers, server or wait",
623: (char *) NULL);
624: return TCL_ERROR;
625:
626: }
627:
628: /*
629: * tcpClientCommand --
630: *
631: * This procedure is invoked to process the "tcp client" Tcl command.
632: * It returns the name of the currently-active client, or an error if there
633: * is none.
634: */
635:
636: /* ARGSUSED */
637: static int
638: tcpClientCommand (clientData, interp, argc, argv)
639: ClientData clientData;
640: Tcl_Interp * interp;
641: int argc;
642: char * * argv;
643: {
644: /* Check syntax */
645:
646: if (argc != 1) {
647: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
648: argv [0], "\"", (char *) NULL);
649: return TCL_ERROR;
650: }
651:
652: /* Make sure there is a current client */
653:
654: if (tcpCurrentClient == NULL) {
655: Tcl_SetResult (interp, "no current client", TCL_STATIC);
656: return TCL_ERROR;
657: }
658:
659: Tcl_SetResult (interp, tcpCurrentClient, TCL_VOLATILE);
660: return TCL_OK;
661: }
662:
663: /* tcpConnectCommand --
664: *
665: * This procedure is invoked to process the "tcp connect" Tcl command.
666: * It takes two arguments: a host name and a port. It tries to establish a
667: * connection to the specified port and host.
668: */
669:
670: /* ARGSUSED */
671: static int
672: tcpConnectCommand (clientData, interp, argc, argv)
673: ClientData clientData;
674: Tcl_Interp * interp;
675: int argc;
676: char * * argv;
677: {
678: struct hostent * host;
679: struct sockaddr_in sockaddr;
680: int haddr;
681: int port;
682: int status;
683: int f;
684: char name [20];
685:
686: /* Check syntax */
687:
688: if (argc != 3) {
689: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [-1], " ",
690: argv [0], " hostname port#\"", (char *) NULL);
691: return TCL_ERROR;
692: }
693:
694: /* Decode the host name */
695:
696: sockaddr.sin_family = AF_INET;
697: host = gethostbyname (argv [1]);
698: if (host != NULL) {
699: memcpy ((char *) &(sockaddr.sin_addr.s_addr),
700: (char *) (host -> h_addr_list [0]),
701: (size_t) (host -> h_length));
702: } else {
703: haddr = inet_addr (argv [1]);
704: if (haddr == -1) {
705: Tcl_AppendResult (interp, argv[1], ": host unknown", (char *) NULL);
706: return TCL_ERROR;
707: }
708: sockaddr.sin_addr.s_addr = haddr;
709: }
710:
711: /* Decode the port number */
712:
713: status = Tcl_GetInt (interp, argv [2], &port);
714: if (status) return status;
715: sockaddr.sin_port = htons (port);
716:
717: /* Make a socket to talk to the server */
718:
719: f = socket (AF_INET, SOCK_STREAM, 0);
720: if (f < 0) {
721: Tcl_AppendResult (interp, "can't create socket: ",
722: Tcl_UnixError (interp), (char *) NULL);
723: return TCL_ERROR;
724: }
725:
726: /* Connect to the server */
727:
728: status = connect (f, (struct sockaddr *) &sockaddr, sizeof sockaddr);
729: if (status < 0) {
730: Tcl_AppendResult (interp, "can't connect to server: ",
731: Tcl_UnixError (interp), (char *) NULL);
732: (void) close (f);
733: return TCL_ERROR;
734: }
735:
736: /* Get the server's greeting message */
737:
738: status = tcpReceiveResultFromServer (interp, f);
739:
740: if (status == TCL_OK) {
741:
742: /* Stash the greeting, make the connection object and return it. */
743:
744: sprintf (name, "tcp_connection_%d", f);
745: (void) Tcl_SetVar2 (interp, "tcp_greeting", name, interp -> result,
746: TCL_GLOBAL_ONLY);
747: Tcl_CreateCommand (interp, name, (Tcl_CmdProc *) tcpConnectionObjectCmd,
748: (ClientData) f,
749: (Tcl_CmdDeleteProc *) deleteTcpConnectionObjectCmd);
750: Tcl_SetResult (interp, name, TCL_VOLATILE);
751: return TCL_OK;
752: } else {
753:
754: /* Error reading greeting, quit */
755:
756: (void) close (f);
757: return TCL_ERROR;
758: }
759: }
760:
761: /*
762: * tcpEvalCommand --
763: *
764: * This procedure is invoked to process the "tcp eval" Tcl command.
765: * "tcp eval" is the default command invoked to process connections once
766: * a connection has been accepted by "tcp login".
767: */
768:
769: /* ARGSUSED */
770: static int
771: tcpEvalCommand (clientData, interp, argc, argv)
772: ClientData clientData;
773: Tcl_Interp * interp;
774: int argc;
775: char * * argv;
776: {
777: int status;
778:
779: /* Argc == 2 means that we're logging out a client. Default is to ignore
780: * the logout.
781: */
782:
783: if (argc == 2) {
784: return TCL_OK;
785: }
786:
787: /* Three-argument form is a command from a client. Default is to eval
788: * the command */
789:
790: if (argc != 3) {
791: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
792: " ", argv [0], " client command\"", (char *) NULL);
793: return TCL_ERROR;
794: }
795:
796: status = Tcl_Eval (interp, argv [2], 0, (char * *) NULL);
797: return status;
798: }
799:
800: /*
801: * tcpLoginCommand --
802: *
803: * This procedure is invoked to process the "tcp login" Tcl command.
804: * It is the default command procedure at initial connection to a server.
805: * It is invoked with the name of a client. It returns TCL_OK, together
806: * with a greeting message, if the login succeeds, and TCL_ERROR, together
807: * with a denial message, if it fails.
808: *
809: * The authentication procedure is as follows:
810: *
811: * - If the client is on the local host, the connection is accepted.
812: * - If the client's IP address is the same as the local host's IP address,
813: * the connection is accepted.
814: * - Otherwise, the connection is refused.
815: *
816: * Obviously, there are other authentication techniques. The use can
817: * replace this command with an arbitrary Tcl script.
818: */
819:
820: /*ARGSUSED*/
821: static int
822: tcpLoginCommand (clientData, interp, argc, argv)
823: ClientData clientData;
824: Tcl_Interp * interp;
825: int argc;
826: char * * argv;
827: {
828: char * hostName; /* Name of the client's host */
829: int status;
830:
831: /* Check command syntax */
832:
833: if (argc != 2) {
834: Tcl_AppendResult (interp, "wrong # args; should be \"", argv [-1], " ",
835: argv [0], " clientName\"", (char *) NULL);
836: return TCL_ERROR;
837: }
838:
839: /* Get the hostname by doing $client hostname */
840:
841: status = Tcl_VarEval (interp, argv [1], " hostname", (char *) NULL);
842: if (status == TCL_OK) {
843: hostName = (char *) ckalloc (strlen (interp -> result) + 1);
844: strcpy (hostName, interp -> result);
845:
846: /* Check that the host is trusted */
847:
848: if (tcpTrustedHost (hostName)) {
849:
850: /* Change the command to `tcp eval' for next time */
851:
852: status = Tcl_VarEval (interp, argv [1], " command {tcp eval}",
853: (char *) NULL);
854:
855:
856: if (status == TCL_OK) {
857:
858: /* Return a greeting message */
859:
860: Tcl_ResetResult (interp);
861: Tcl_AppendResult (interp, "GE DICE TCP-based Tcl server\n", RCSid,
862: "\n", copyright, (char *) NULL);
863:
864: return TCL_OK;
865:
866: }
867:
868: }
869:
870: ckfree ((char *) hostName);
871: }
872:
873: /* Host isn't trusted or one of the commands failed. */
874:
875: Tcl_SetResult (interp, "Permission denied", TCL_STATIC);
876: return TCL_ERROR;
877: }
878:
879: /*
880: * tcpMainLoopCommand:
881: *
882: * This procedure is invoked in a non-Tk environment when the server
883: * implementor wishes to use a main loop built into the library. It
884: * repeatedly polls ofr work to be done, returning only when the last server
885: * is closed.
886: *
887: * In a Tk environment, the procedure returns immediately.
888: */
889:
890: /*ARGSUSED*/
891: static int
892: tcpMainLoopCommand (clientData, interp, argc, argv)
893: ClientData clientData;
894: Tcl_Interp * interp;
895: int argc;
896: char * * argv;
897: {
898:
899: int status;
900:
901: if (argc != 1) {
902: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
903: " ", argv [0], "\"", (char *) NULL);
904: return TCL_ERROR;
905: }
906:
907: errno = 0; status = -1;
908:
909: /* In a non-Tk environment, errno has a Unix error or 0 for no clients
910: * or servers. In a Tk environment, errno is zero at this point.
911: */
912:
913: if (errno != 0) {
914: Tcl_AppendResult (interp, "select: ", Tcl_UnixError (interp),
915: (char *) NULL);
916: return TCL_ERROR;
917: }
918:
919: return TCL_OK;
920: }
921:
922:
923: /*
924: * tcpPollCommand:
925: *
926: * This procedure is invoked to process the "tcp poll" Tcl
927: * command. It requests that pending events for the servers be processed.
928: * It returns a count of events that were processed successfully.
929: *
930: * In a Tk environment, the procedure reports that no servers are known
931: * to the event handler. This is correct -- servers register with Tk, not
932: * with the simple event handler.
933: */
934:
935: /*ARGSUSED*/
936: static int
937: tcpPollCommand (clientData, interp, argc, argv)
938: ClientData clientData;
939: Tcl_Interp * interp;
940: int argc;
941: char * * argv;
942: {
943: int status;
944:
945: if (argc != 1) {
946: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
947: " ", argv [0], "\"", (char *) NULL);
948: return TCL_ERROR;
949: }
950:
951: /* Do the poll */
952:
953: errno = 0; status = -1;
954:
955: /* Check for trouble */
956:
957: if (status < 0) {
958: if (errno == 0) {
959: Tcl_SetResult (interp, "no servers known to event handler", TCL_STATIC);
960: } else {
961: Tcl_AppendResult (interp, "select: ", Tcl_UnixError (interp),
962: (char *) NULL);
963: }
964: return TCL_ERROR;
965: }
966:
967: /* Return the number of events processed. */
968:
969: sprintf (interp -> result, "%d", status);
970: return TCL_OK;
971: }
972:
973: /* tcpServerCommand:
974: *
975: * This procedure is invoked to process the "tcp server" Tcl
976: * command. It requests that a server be created to listen at a
977: * TCP/IP port, whose number may be assigned by the system or
978: * specified by the user with the "-port" option.
979: *
980: * A command string is supplied for use when the server begins to
981: * accept connections. See the documentation of tcpServerObjectCmd
982: * for a description of the command string.
983: *
984: * If the server is created successfully, the return value will
985: * be the name of a "server object" that can be used for future
986: * actions upon the server. This object will be usable as a Tcl
987: * command; the command is processed by the tcpServerObjectCmd function.
988: *
989: * Syntax:
990: * tcp server ?-port #? ?-command string?
991: *
992: * Results:
993: * A standard Tcl result. Return value is the name of the server
994: * object, which may be invoked as a Tcl command (see
995: * tcpServerObjectCmd for details).
996: */
997:
998: /* ARGSUSED */
999: static int
1000: tcpServerCommand (clientData, interp, argc, argv)
1001: ClientData clientData;
1002: Tcl_Interp * interp;
1003: int argc;
1004: char * * argv;
1005: {
1006: int unixStatus;
1007: int one;
1008: char * message;
1009: char * nargv [3];
1010: int nargc;
1011:
1012: /* Create a structure to hold the tcp server's description. */
1013:
1014: Tcp_ServerData * server =
1015: (Tcp_ServerData *) ckalloc (sizeof (Tcp_ServerData));
1016:
1017: /* Set up the interpreter and the default command. Clear the list of
1018: * clients. */
1019:
1020: server -> interp = interp;
1021: server -> command = "tcp login";
1022: server -> freeCommand = TCL_STATIC;
1023: server -> stopFlag = 0;
1024: server -> raw = 0;
1025: server -> firstClient = (Tcp_ClientData *) NULL;
1026:
1027: /* Create the socket at which the server will listen. */
1028:
1029: server -> socketfd = socket (AF_INET, SOCK_STREAM, 0);
1030: if (server -> socketfd < 0) {
1031: Tcl_AppendResult (interp, "can't create socket: ",
1032: Tcl_UnixError (interp), (char *) NULL);
1033: } else {
1034:
1035: /* Set up the socket for non-blocking I/O. */
1036:
1037: one = 1;
1038: unixStatus = ioctl (server -> socketfd, FIONBIO, (char *) &one);
1039: if (unixStatus < 0) {
1040: Tcl_AppendResult (interp, "can't set non-blocking I/O on socket: ",
1041: Tcl_UnixError (interp), (char *) NULL);
1042: } else {
1043:
1044: /* Server structure has been created and socket has been opened.
1045: * Now configure the server.
1046: */
1047:
1048: if (tcpServerObjectConfig ((ClientData) server, interp, argc, argv)
1049: == TCL_OK)
1050: {
1051:
1052: /* Link the server on the list of active servers */
1053:
1054: if (tcpFirstServer)
1055: tcpFirstServer -> prev = server;
1056: server -> next = tcpFirstServer;
1057: tcpFirstServer = server;
1058: server -> prev = NULL;
1059:
1060: /* Add the server object command */
1061:
1062: sprintf (server -> name, "tcp_server_%d", server -> socketfd);
1063:
1064: Tcl_CreateCommand (interp, server -> name,
1065: (Tcl_CmdProc *) tcpServerObjectCmd,
1066: (ClientData) server,
1067: (Tcl_CmdDeleteProc *) deleteTcpServerObjectCmd);
1068:
1069: Tcl_SetResult (interp, server -> name, TCL_STATIC);
1070:
1071: return TCL_OK;
1072:
1073: }
1074: }
1075:
1076: /* Error in configuring the server. Trash the socket. */
1077:
1078: unixStatus = close (server -> socketfd);
1079: if (unixStatus < 0) {
1080: nargc = 3;
1081: nargv [0] = "(also failed to close socket: ";
1082: nargv [1] = Tcl_UnixError (interp);
1083: nargv [2] = ")";
1084: message = Tcl_Concat (nargc, nargv);
1085: Tcl_AddErrorInfo (interp, message);
1086: free (message);
1087: }
1088: }
1089:
1090: /* Error in creating the server -- get rid of the data structure */
1091:
1092: if (server -> freeCommand != NULL) {
1093: (*(server -> freeCommand)) (server -> command);
1094: }
1095: ckfree ((char *) server);
1096: return TCL_ERROR;
1097: }
1098:
1099: /*
1100: * tcpServersCommand:
1101: *
1102: * The following procedure is invoked to process the `tcp servers' Tcl
1103: * command. It returns a list of the servers that are currently known.
1104: */
1105:
1106: /* ARGSUSED */
1107: static int
1108: tcpServersCommand (clientData, interp, argc, argv)
1109: ClientData clientData;
1110: Tcl_Interp * interp;
1111: int argc;
1112: char * * argv;
1113: {
1114: Tcp_ServerData * server;
1115:
1116: /* Check syntax */
1117:
1118: if (argc != 1) {
1119: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
1120: argv [0], "\"", (char *) NULL);
1121: return TCL_ERROR;
1122: }
1123:
1124: for (server = tcpFirstServer; server != NULL; server = server -> next) {
1125: Tcl_AppendElement (interp, server -> name, 0);
1126: }
1127:
1128: return TCL_OK;
1129: }
1130:
1131: /*
1132: * tcpWaitCommand:
1133: *
1134: * This procedure is invoked to process the "tcp wait" Tcl
1135: * command. It requests that the process delay until an event is
1136: * pending for a TCP server.
1137: *
1138: * It returns a count of pending events.
1139: *
1140: * In a Tk environment, the procedure returns an error message stating
1141: * that no servers are known to the event handler. This is correct. The
1142: * servers register with Tk's event handler, and are not known to the simple
1143: * event handler.
1144: */
1145:
1146: /*ARGSUSED*/
1147: static int
1148: tcpWaitCommand (clientData, interp, argc, argv)
1149: ClientData clientData;
1150: Tcl_Interp * interp;
1151: int argc;
1152: char * * argv;
1153: {
1154: int status;
1155:
1156: if (argc != 1) {
1157: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
1158: " ", argv [0], "\"", (char *) NULL);
1159: return TCL_ERROR;
1160: }
1161:
1162: /* Do the poll */
1163:
1164: errno = 0; status = -1;
1165:
1166: /* Check for trouble */
1167:
1168: if (status < 0) {
1169: if (errno == 0) {
1170: Tcl_SetResult (interp, "no servers known to event handler", TCL_STATIC);
1171: } else {
1172: Tcl_AppendResult (interp, "select: ", Tcl_UnixError (interp),
1173: (char *) NULL);
1174: }
1175: return TCL_ERROR;
1176: }
1177:
1178: /* Return the number of events pending. */
1179:
1180: sprintf (interp -> result, "%d", status);
1181: return TCL_OK;
1182: }
1183:
1184: /*
1185: * tcpServerObjectCmd --
1186: *
1187: * This procedure is invoked when a command is called on a server
1188: * object directly. It dispatches to the appropriate command processing
1189: * procedure to handle the command.
1190: *
1191: * $server accept
1192: * [Internal call] - Accept a connection.
1193: * $server clients
1194: * Return a list of all clients connected to a server.
1195: * $server configure ?args?
1196: * Revise or query a server's configuration.
1197: * $server start
1198: * Start a server running.
1199: * $server stop
1200: * Terminate a server.
1201: */
1202:
1203: static int
1204: tcpServerObjectCmd (clientData, interp, argc, argv)
1205: ClientData clientData;
1206: Tcl_Interp * interp;
1207: int argc;
1208: char * * argv;
1209: {
1210: int c;
1211: unsigned length;
1212:
1213: if (argc < 2) {
1214: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [0],
1215: " command ?args?\"", (char *) NULL);
1216: return TCL_ERROR;
1217: }
1218:
1219: c = argv [1] [0];
1220: length = strlen (argv [1]);
1221:
1222: if (c == 'a' && strncmp (argv [1], "accept", length) == 0) {
1223: return tcpServerObjectAcceptCmd (clientData, interp, argc-1, argv+1);
1224: }
1225: if (c == 'c' && length >= 2 && strncmp (argv [1], "clients", length) == 0) {
1226: return tcpServerObjectClientsCmd (clientData, interp, argc-1, argv+1);
1227: }
1228: if (c == 'c' && length >= 2
1229: && strncmp (argv [1], "configure", length) == 0) {
1230: return tcpServerObjectConfigCmd (clientData, interp, argc-1, argv+1);
1231: }
1232: if (c == 's' && length >= 3 && strncmp (argv [1], "start", length) == 0) {
1233: return tcpServerObjectStartCmd (clientData, interp, argc-1, argv+1);
1234: }
1235: if (c == 's' && length >= 3 && strncmp (argv [1], "stop", length) == 0) {
1236: return tcpServerObjectStopCmd (clientData, interp, argc-1, argv+1);
1237: }
1238: Tcl_AppendResult (interp, argv [0], ": ", "bad option \"", argv [1],
1239: "\": should be clients, configure, start, or stop",
1240: (char *) NULL);
1241: return TCL_ERROR;
1242: }
1243:
1244: /*
1245: * tcpServerObjectAcceptCmd --
1246: *
1247: * The following procedure handles the `accept' command on a
1248: * server object. It is called in the background by
1249: * tcpServerAcceptConnection when a connection request appears on
1250: * a server. It is responsible for creating the client and
1251: * accepting the connection request.
1252: *
1253: * Results:
1254: * Returns a standard TCL result. The return value is the name
1255: * of the client if the call is successful.
1256: *
1257: * Side effects:
1258: * A Tcl command named after the client object is created.
1259: */
1260:
1261: static int
1262: tcpServerObjectAcceptCmd (clientData, interp, argc, argv)
1263: ClientData clientData;
1264: Tcl_Interp * interp;
1265: int argc;
1266: char * * argv;
1267: {
1268: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1269: register Tcp_ClientData * client;
1270: int rubbish;
1271: int unixStatus;
1272: int nargc;
1273: char * nargv [3];
1274: char * message;
1275:
1276: /* Check command syntax */
1277:
1278: if (argc != 1) {
1279: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [-1], " ",
1280: argv [0], "\"", (char *) NULL);
1281: return TCL_ERROR;
1282: }
1283:
1284: /* Create the client data structure */
1285:
1286: client = (Tcp_ClientData *) ckalloc (sizeof (Tcp_ClientData));
1287:
1288: /* Accept the client's connection request */
1289:
1290: rubbish = sizeof (struct sockaddr_in);
1291: client -> socketfd = accept (server -> socketfd,
1292: (struct sockaddr *) &(client -> peeraddr),
1293: &rubbish);
1294: if (client -> socketfd < 0) {
1295: Tcl_AppendResult (interp, "can't accept connection: ",
1296: Tcl_UnixError (interp), (char *) NULL);
1297: ckfree ((char *) client);
1298: return TCL_ERROR;
1299: }
1300:
1301: /* Set up the socket for non-blocking I/O */
1302:
1303: rubbish = 1;
1304: unixStatus = ioctl (client -> socketfd, FIONBIO, (char *) &rubbish);
1305: if (unixStatus < 0) {
1306: Tcl_AppendResult (interp,
1307: "can't set non-blocking I/O on client's socket: ",
1308: Tcl_UnixError (interp), (char *) NULL);
1309: unixStatus = close (client -> socketfd);
1310: if (unixStatus < 0) {
1311: nargc = 3;
1312: nargv [0] = "(also failed to close socket: ";
1313: nargv [1] = Tcl_UnixError (interp);
1314: nargv [2] = ")";
1315: message = Tcl_Concat (nargc, nargv);
1316: Tcl_AddErrorInfo (interp, message);
1317: free (message);
1318: }
1319: ckfree ((char *) client);
1320: return TCL_ERROR;
1321: }
1322:
1323: /* Set up the client's description */
1324:
1325: client -> server = server;
1326: sprintf (client -> name, "tcp_client_%d", client -> socketfd);
1327: client -> command = malloc (strlen (server -> command) + 1);
1328: client -> freeCommand = (Tcl_FreeProc *) free;
1329: strcpy (client -> command, server -> command);
1330: client -> inputBuffer = Tcl_CreateCmdBuf ();
1331: client -> resultString = client -> resultPointer = (char *) NULL;
1332: client -> freeResultString = (Tcl_FreeProc *) NULL;
1333: client -> activeFlag = 0;
1334: client -> closeFlag = 0;
1335: client -> next = server -> firstClient;
1336: if (client -> next != NULL) {
1337: client -> next -> prev = client;
1338: }
1339: client -> prev = NULL;
1340: server -> firstClient = client;
1341:
1342: /* Create the Tcl command for the client */
1343:
1344: Tcl_CreateCommand (interp, client -> name,
1345: (Tcl_CmdProc *) tcpClientObjectCmd,
1346: (ClientData) client,
1347: (Tcl_CmdDeleteProc *) deleteTcpClientObjectCmd);
1348:
1349: /* Return the client's name */
1350:
1351: Tcl_SetResult (interp, client -> name, TCL_STATIC);
1352: return TCL_OK;
1353: }
1354:
1355: /*
1356: * tcpServerObjectClientsCmd --
1357: *
1358: * This procedure in invoked in response to the `clients' command
1359: * on a TCP server object. It returns a list of clients for the server.
1360: */
1361:
1362: static int
1363: tcpServerObjectClientsCmd (clientData, interp, argc, argv)
1364: ClientData clientData;
1365: Tcl_Interp * interp;
1366: int argc;
1367: char * * argv;
1368: {
1369: Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1370: Tcp_ClientData * client;
1371:
1372: /* Check syntax */
1373:
1374: if (argc != 1) {
1375: Tcl_AppendResult (interp, "wrong # args, should be\"", argv [-1], " ",
1376: argv [0], "\"", (char *) NULL);
1377: return TCL_ERROR;
1378: }
1379:
1380: for (client = server -> firstClient; client != NULL;
1381: client = client -> next) {
1382: Tcl_AppendElement (interp, client -> name, 0);
1383: }
1384:
1385: return TCL_OK;
1386: }
1387:
1388: /*
1389: * tcpServerObjectConfigCmd --
1390: *
1391: * This procedure is invoked in response to the `config' command
1392: * on a TCP server object. With no arguments, it returns a list
1393: * of valid arguments. With one argument, it returns the current
1394: * value of that option. With multiple arguments, it attempts to
1395: * configure the server according to that argument list.
1396: * Results:
1397: * Returns a standard Tcl result.
1398: */
1399:
1400: static int
1401: tcpServerObjectConfigCmd (clientData, interp, argc, argv)
1402: ClientData clientData;
1403: Tcl_Interp * interp;
1404: int argc;
1405: char * * argv;
1406: {
1407: int unixStatus;
1408: int c;
1409: unsigned length;
1410:
1411: /* No arguments -- return a list of valid options. */
1412:
1413: if (argc <= 1) {
1414: Tcl_SetResult (interp, "-command -port", TCL_STATIC);
1415: return TCL_OK;
1416: }
1417:
1418: /* One argument -- query a particular option */
1419:
1420: if (argc == 2) {
1421: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1422: char * arg = argv [1];
1423:
1424: if (arg [0] != '-') {
1425: Tcl_AppendResult (interp, argv [-1], " ", argv [0],
1426: ": bad option \"", arg,
1427: "\" -- each option must begin with a hyphen.",
1428: (char *) NULL);
1429: return TCL_ERROR;
1430:
1431: }
1432:
1433: length = strlen (++arg);
1434: c = arg [0];
1435:
1436: if (c == 'c' && strncmp (arg, "command", length) == 0) {
1437:
1438: /* Command option -- Get the command name */
1439:
1440: Tcl_SetResult (interp, server->name, TCL_STATIC);
1441: return TCL_OK;
1442:
1443: }
1444:
1445: if (c == 'p' && strncmp (arg, "port", length) == 0) {
1446:
1447: /* Port option -- Get the port number */
1448:
1449: struct sockaddr_in portaddr;
1450: int rubbish = sizeof (struct sockaddr_in);
1451:
1452: unixStatus = getsockname (server -> socketfd,
1453: (struct sockaddr *) &portaddr, &rubbish);
1454: if (unixStatus < 0) {
1455: Tcl_AppendResult (interp, argv [-1], ": can't read port #: ",
1456: Tcl_UnixError (interp), (char *) NULL);
1457: return TCL_ERROR;
1458: }
1459: Tcl_ResetResult (interp);
1460: sprintf (interp -> result, "%d", (int) ntohs (portaddr.sin_port));
1461: return TCL_OK;
1462: }
1463:
1464: /* Unknown option */
1465:
1466: Tcl_AppendResult (interp, argv [-1], ": unknown option \"", arg,
1467: "\" -- must be -command or -port", (char *) NULL);
1468: return TCL_ERROR;
1469: }
1470:
1471: return tcpServerObjectConfig (clientData, interp, argc, argv);
1472: }
1473:
1474: /*
1475: * tcpServerObjectStartCmd --
1476: *
1477: * This procedure is invoked to process the "start" command on a
1478: * TCP server object. It sets the server up so that new
1479: * connection requests will create "server-client" objects and
1480: * invoke the server's command with them.
1481: *
1482: * If Tk is available, the "start" command returns to the caller.
1483: * If Tk is not available, the "start" command immediately enters
1484: * a loop that attempts to process the connection events (and
1485: * other file events as well). The loop may be exited by
1486: * executing a `stop' command on the server object. (The `stop'
1487: * command also exists in the Tk environment, since there is more
1488: * to stopping a server than just breaking out of its event
1489: * loop.)
1490: */
1491:
1492: static int
1493: tcpServerObjectStartCmd (clientData, interp, argc, argv)
1494: ClientData clientData;
1495: Tcl_Interp * interp;
1496: int argc;
1497: char * * argv;
1498: {
1499: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1500: int unixStatus;
1501:
1502: /* Check command syntax */
1503:
1504: if (argc != 1) {
1505: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [-1], " ",
1506: argv [0], "\"", (char *) NULL);
1507: return TCL_ERROR;
1508: }
1509:
1510: /* Listen at the server's socket */
1511:
1512: unixStatus = listen (server -> socketfd, TCP_LISTEN_BACKLOG);
1513: if (unixStatus < 0) {
1514: Tcl_AppendResult (interp, argv [-1], ": can't listen at socket: ",
1515: Tcl_UnixError (interp), (char *) NULL);
1516: return TCL_ERROR;
1517: }
1518:
1519: /* Add a file handler to gain control at tcpServerAcceptConnection
1520: * whenever a client attempts to connect.
1521: */
1522:
1523: simpleCreateFileHandler (server -> socketfd, TK_READABLE,
1524: (Tk_FileProc *) tcpServerAcceptConnection,
1525: clientData);
1526: return TCL_OK;
1527: }
1528:
1529: /*
1530: * tcpServerObjectStopCmd
1531: *
1532: * This procedure is invoked in response to the `$server stop' Tcl
1533: * command. It destroys the server's object command. Destroying the object
1534: * command, in turn, attempts to shut down the server in question. It closes
1535: * the listen socket, closes all the clients, and sets the `stop' flag for
1536: * the server itself. It then calls `tcpServerClose' to try to get rid of
1537: * the server.
1538: *
1539: * If one or more clients are active, the server does not shut down
1540: * until they can be closed properly.
1541: */
1542:
1543: static int
1544: tcpServerObjectStopCmd (clientData, interp, argc, argv)
1545: ClientData clientData;
1546: Tcl_Interp * interp;
1547: int argc;
1548: char * * argv;
1549: {
1550: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1551:
1552: if (argc != 1) {
1553: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
1554: " ", argv [0], "\"", (char *) NULL);
1555: return TCL_ERROR;
1556: }
1557:
1558: /* Delete the server command */
1559:
1560: Tcl_DeleteCommand (interp, server -> name);
1561:
1562: return TCL_OK;
1563: }
1564:
1565: /*
1566: * deleteTcpServerObjectCmd --
1567: *
1568: * This procedure is called when a server's object command is deleted.
1569: *
1570: * It is the first procedure called when a server is shut down. It
1571: * closes the listen socket and deletes its file handler. It also attempts
1572: * to close all the clients.
1573: *
1574: * It may be that a client needs to be able to complete a data transfer
1575: * before it can be closed. In this case, the `close flag' for the client is
1576: * set. The client will be deleted when it reaches a quiescent point.
1577: *
1578: * Once all the clients are gone, tcpDeleteServer removes the server's
1579: * client data structure.
1580: */
1581:
1582: static void
1583: deleteTcpServerObjectCmd (clientData)
1584: ClientData clientData;
1585: {
1586: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1587: register Tcp_ClientData * client, * nextClient;
1588:
1589: /* Close the listen socket and delete its handler */
1590:
1591: simpleDeleteFileHandler (server -> socketfd);
1592: (void) close (server -> socketfd);
1593: server -> socketfd = -1;
1594:
1595: /* Close all clients */
1596:
1597: for (client = server -> firstClient; client != NULL; client = nextClient) {
1598: nextClient = client -> next;
1599: if (client -> activeFlag)
1600: client -> closeFlag = 1;
1601: else
1602: tcpCloseClient (client);
1603: }
1604:
1605: /* Remove the server from the list of servers. */
1606:
1607: if (server -> next != NULL)
1608: server -> next -> prev = server -> prev;
1609: if (server -> prev != NULL)
1610: server -> prev -> next = server -> next;
1611: else
1612: tcpFirstServer = server -> next;
1613:
1614: /* If all clients are closed, get to tcpDeleteServer now. Otherwise, set
1615: * the server's stop flag and return.
1616: */
1617:
1618: if (server -> firstClient == NULL) {
1619: tcpDeleteServer (server);
1620: } else {
1621: server -> stopFlag = 1;
1622: }
1623: }
1624:
1625: /*
1626: * tcpDeleteServer --
1627: *
1628: * This procedure is invoked as the final phase of deleting a TCP server.
1629: * When execution gets here, the server's listen socket has been closed and
1630: * the handler has been removed. The server's object command has been deleted.
1631: * The server has been removed from the list of active servers. All the
1632: * server's clients have been closed. The server's login command has been
1633: * deleted. All that remains is to deallocate the server's data structures.
1634: */
1635:
1636: static void
1637: tcpDeleteServer (server)
1638: Tcp_ServerData * server;
1639: {
1640: /* Get rid of the server's initial command */
1641:
1642: if (server -> command != NULL && server -> freeCommand != NULL) {
1643: (*(server -> freeCommand)) (server -> command);
1644: }
1645:
1646: /* Get rid of the server's own data structure */
1647:
1648: (void) ckfree ((char *) server);
1649: }
1650:
1651: /*
1652: * tcpServerObjectConfig --
1653: *
1654: * This procedure is invoked to configure a TCP server object.
1655: * It may be called from tcpServerCommand when the server is
1656: * first being created, or else from tcpServerObjectCmd if the
1657: * server object is called with the "config" option.
1658: *
1659: * In any case, the arguments are expected to contain zero or
1660: * more of the following:
1661: *
1662: * -port <number>
1663: * Requests that the server listen at a specific port.
1664: * Default is whatever the system assigns.
1665: *
1666: * -command <string>
1667: * Specifies the initial command used when a client
1668: * first connects to the server. The command is
1669: * concatenated with the name of a "server-client" object
1670: * that identifies the client, and then called:
1671: * command client
1672: * Default is "tcp login"
1673: *
1674: * -raw
1675: * Puts the server in raw socket mode.
1676: *
1677: * Result:
1678: * A standard TCL result.
1679: */
1680:
1681: static int
1682: tcpServerObjectConfig (clientData, interp, argc, argv)
1683: ClientData clientData;
1684: Tcl_Interp * interp;
1685: int argc;
1686: char * * argv;
1687: {
1688:
1689: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
1690:
1691: int status;
1692: int unixStatus;
1693:
1694: /* On entry, argc shows one plus the number of parameters. Argv[-1] */
1695: /* and argv[0] give the command that got us here: either "tcp */
1696: /* server" or else "serverName config" */
1697:
1698: int a;
1699: unsigned length;
1700: int c;
1701:
1702: /* Step through the parameters */
1703:
1704: for (a = 1; a < argc; ++a) {
1705: char * arg = argv [a];
1706:
1707: if (arg [0] != '-') {
1708: Tcl_AppendResult (interp, argv [-1], ": bad option \"", arg,
1709: "\" -- each option must begin with a hyphen.",
1710: (char *) NULL);
1711: return TCL_ERROR;
1712: } else {
1713:
1714: length = strlen (++arg);
1715: c = arg [0];
1716:
1717: if (c == 'c' && strncmp (arg, "command", length) == 0) {
1718:
1719: /* Command option -- Get the command name */
1720:
1721: ++a;
1722: if (a >= argc) {
1723: Tcl_AppendResult (interp, argv [-1],
1724: ": \"-command\" must be followed by a string.",
1725: (char *) NULL);
1726: return TCL_ERROR;
1727: }
1728:
1729: /* Free the old command name */
1730:
1731: if (server -> freeCommand != NULL) {
1732: (*(server -> freeCommand)) (server -> command);
1733: }
1734:
1735: /* Put in the new command name */
1736:
1737: server -> command = (char *) malloc (strlen (argv [a]) + 1);
1738: strcpy (server -> command, argv [a]);
1739: server -> freeCommand = (Tcl_FreeProc *) free;
1740:
1741: } else if (c == 'p' && strncmp (arg, "port", length) == 0) {
1742:
1743: /* Port option -- get the port number */
1744:
1745: char * portstr;
1746: int portno;
1747: struct sockaddr_in portaddr;
1748:
1749: ++a;
1750: if (a >= argc) {
1751: Tcl_AppendResult (interp, argv [-1],
1752: ": \"-port\" must be followed by a number.",
1753: (char *) NULL);
1754: return TCL_ERROR;
1755: }
1756: portstr = argv [a];
1757: status = Tcl_GetInt (interp, portstr, &portno);
1758: if (status) return status;
1759:
1760: /* Set the port number */
1761:
1762: memset ((void *) & portaddr, 0, sizeof (struct sockaddr_in));
1763: portaddr.sin_port = htons (portno);
1764: unixStatus = bind (server -> socketfd,
1765: (struct sockaddr *) &portaddr,
1766: sizeof (struct sockaddr_in));
1767: if (unixStatus < 0) {
1768: Tcl_AppendResult (interp, argv [-1],
1769: ": can't set port number: ",
1770: Tcl_UnixError (interp), (char *) NULL);
1771: return TCL_ERROR;
1772: }
1773:
1774: } else if (c == 'r' && strncmp (arg, "raw", length) == 0) {
1775:
1776: /* raw option -- set raw socket mode */
1777:
1778: server -> raw = 1;
1779:
1780: } else {
1781:
1782: /* Unknown option */
1783:
1784: Tcl_AppendResult (interp, argv [-1],
1785: ": unknown option \"", arg - 1,
1786: "\" -- must be -command or -port", (char *) NULL);
1787: return TCL_ERROR;
1788: }
1789: }
1790: }
1791:
1792: Tcl_SetResult (interp, server -> name, TCL_STATIC);
1793: return TCL_OK;
1794: }
1795:
1796: /*
1797: * tcpClientObjectCmd --
1798: *
1799: * This procedure handles the object command for a Tcp client (on
1800: * the server side). It takes several forms:
1801: * $client command ?command?
1802: * With no arguments, returns the client's
1803: * current command. With arguments, replaces the
1804: * client's command with the arguments
1805: * $client close
1806: * Deletes the client. If a command is being
1807: * processed on the client's behalf, the client
1808: * will not be deleted until the command's result
1809: * is returned.
1810: * $client do ?args?
1811: * Concatenate the client's command with ?args?,
1812: * and execute the result. Called in background
1813: * when a command arrives and on initial
1814: * connection.
1815: * $client hostname
1816: * Returns the name of the host where the client
1817: * is running.
1818: * $client server
1819: * Returns the name of the server to which the client
1820: * is connected.
1821: */
1822:
1823: static int
1824: tcpClientObjectCmd (clientData, interp, argc, argv)
1825: ClientData clientData;
1826: Tcl_Interp * interp;
1827: int argc;
1828: char * * argv;
1829: {
1830: int c;
1831: unsigned length;
1832:
1833: if (argc < 2) {
1834: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [0],
1835: " command ?args?\"", (char *) NULL);
1836: return TCL_ERROR;
1837: }
1838:
1839: c = argv [1] [0];
1840: length = strlen (argv [1]);
1841:
1842: if (c == 'c' && length >= 2 && strncmp (argv [1], "close", length) == 0) {
1843: return tcpClientObjectCloseCmd (clientData, interp, argc-1, argv+1);
1844: }
1845: if (c == 'c' && length >= 2 && strncmp (argv [1], "command", length) == 0) {
1846: return tcpClientObjectCommandCmd (clientData, interp, argc-1, argv+1);
1847: }
1848: if (c == 'd' && strncmp (argv [1], "do", length) == 0) {
1849: return tcpClientObjectDoCmd (clientData, interp, argc-1, argv+1);
1850: }
1851: if (c == 'h' && strncmp (argv [1], "hostname", length) == 0) {
1852: return tcpClientObjectHostnameCmd (clientData, interp, argc-1, argv+1);
1853: }
1854: if (c == 's' && strncmp (argv [1], "server", length) == 0) {
1855: return tcpClientObjectServerCmd (clientData, interp, argc-1, argv+1);
1856: }
1857:
1858: Tcl_AppendResult (interp, "bad option \"", argv [1],
1859: "\": should be close, command, do, hostname or server",
1860: (char *) NULL);
1861: return TCL_ERROR;
1862: }
1863:
1864: /*
1865: * tcpClientObjectCloseCmd --
1866: *
1867: * This procedure is called when the Tcl program wants to close a client.
1868: * If the client is active, it sets a flag to close the client when it
1869: * becomes quiescent. Otherwise, it closes the client immediately.
1870: */
1871:
1872: static int
1873: tcpClientObjectCloseCmd (clientData, interp, argc, argv)
1874: ClientData clientData;
1875: Tcl_Interp * interp;
1876: int argc;
1877: char * * argv;
1878: {
1879: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
1880:
1881: if (argc != 1) {
1882: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
1883: argv [0], "\"", (char *) NULL);
1884: return TCL_ERROR;
1885: }
1886:
1887: if (client -> activeFlag)
1888: client -> closeFlag = 1;
1889: else
1890: tcpCloseClient (client);
1891:
1892: return TCL_OK;
1893: }
1894:
1895: /*
1896: * tcpClientObjectCommandCmd --
1897: *
1898: * Query/change the command associated with a client object
1899: *
1900: * Syntax:
1901: * $client command ?newcommand?
1902: *
1903: * Return:
1904: * A standard Tcl result containing the client's command.
1905: */
1906:
1907: static int
1908: tcpClientObjectCommandCmd (clientData, interp, argc, argv)
1909: ClientData clientData;
1910: Tcl_Interp * interp;
1911: int argc;
1912: char * * argv;
1913: {
1914: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
1915:
1916: /* Check syntax */
1917:
1918: if (argc > 2) {
1919: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
1920: argv [0], " ?command?\"", (char *) NULL);
1921: return TCL_ERROR;
1922: }
1923:
1924: /* Set command if necessary */
1925:
1926: if (argc == 2) {
1927: if (client -> freeCommand != (Tcl_FreeProc *) NULL) {
1928: (*client -> freeCommand) (client -> command);
1929: }
1930: client -> command = malloc (strlen (argv [1]) + 1);
1931: strcpy (client -> command, argv [1]);
1932: client -> freeCommand = (Tcl_FreeProc *) free;
1933: }
1934:
1935: /* Return command in any case */
1936:
1937: Tcl_SetResult (interp, client -> command, TCL_STATIC);
1938:
1939: return TCL_OK;
1940: }
1941:
1942: /*
1943: * tcpClientObjectDoCmd --
1944: *
1945: * The following procedure handles the `do' command on a client
1946: * object. It is called
1947: * (a) as "$client do", at login.
1948: * (b) as "$client do <command>", when the client sends a
1949: * command.
1950: * (c) as "$client do", with no further arguments, when
1951: * the connection is closed.
1952: * It concatenates the client's saved command string with the
1953: * client's name, and then with the passed command, resulting in
1954: * a command:
1955: * saved_command client passed_command
1956: * which is then passed to Tcl_Eval for processing.
1957: * During the processing of the command, the `active' flag is set for
1958: * the client, to avoid having the client closed prematurely.
1959: */
1960: static int
1961: tcpClientObjectDoCmd (clientData, interp, argc, argv)
1962: ClientData clientData;
1963: Tcl_Interp * interp;
1964: int argc;
1965: char * * argv;
1966: {
1967:
1968: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
1969: int status;
1970: int closeflag;
1971: char * prevClient;
1972: char * excmd;
1973: unsigned excmdl;
1974: int scanflags;
1975:
1976: /* Check command syntax */
1977:
1978: if (argc > 2) {
1979: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1],
1980: " ", argv [0], " ?command?\"", (char *) NULL);
1981: return TCL_ERROR;
1982: }
1983:
1984: prevClient = tcpCurrentClient;
1985: tcpCurrentClient = client -> name;
1986:
1987: /* Evaluate the client's command, passing the client name and message */
1988:
1989: closeflag = 0;
1990: client -> activeFlag = 1;
1991:
1992: if (argc == 2) {
1993: excmdl = Tcl_ScanElement (argv [1], &scanflags) + 1;
1994: excmd = (char *) ckalloc (excmdl);
1995: excmdl = Tcl_ConvertElement (argv [1], excmd, scanflags);
1996: excmd [excmdl] = '\0';
1997: } else {
1998: excmd = (char *) NULL;
1999: }
2000:
2001: status = Tcl_VarEval (interp, client -> command, " ", client -> name, " ",
2002: excmd, (char *) NULL);
2003:
2004: if (excmd)
2005: ckfree (excmd);
2006:
2007: if (status != TCL_OK && argc < 2) {
2008: closeflag = 1;
2009: }
2010:
2011: client -> activeFlag = 0;
2012: tcpCurrentClient = prevClient;
2013:
2014: /* If the client command throws an error on login or logout,
2015: * the client should be disconnected.
2016: * In any case, the result should be reported back to the client.
2017: */
2018:
2019: if (! (client -> server -> raw)) {
2020: tcpReturnResultToClient (client, interp, status, closeflag);
2021: } else {
2022: tcpPrepareClientForInput (client);
2023: }
2024:
2025: /* The client may have been closed by the ReturnResult operation. DON'T
2026: * USE IT AFTER THIS POINT.
2027: */
2028:
2029: return TCL_OK;
2030: }
2031:
2032: /*
2033: * tcpClientObjectHostnameCmd --
2034: *
2035: * This procedure is invoked in response to the `$client hostname'
2036: * Tcl command. It returns the name of the peer host on which the client
2037: * runs.
2038: */
2039:
2040: static int
2041: tcpClientObjectHostnameCmd (clientData, interp, argc, argv)
2042: ClientData clientData;
2043: Tcl_Interp * interp;
2044: int argc;
2045: char * * argv;
2046: {
2047: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
2048:
2049: struct hostent * hostdesc;
2050:
2051: if (argc != 1) {
2052: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
2053: argv [0], "\"", (char *) NULL);
2054: return TCL_ERROR;
2055: }
2056:
2057: hostdesc = gethostbyaddr ((char *) &(client -> peeraddr.sin_addr.s_addr),
2058: sizeof (client -> peeraddr.sin_addr.s_addr),
2059: AF_INET);
2060:
2061: if (hostdesc != (struct hostent *) NULL) {
2062: Tcl_SetResult (interp, hostdesc -> h_name, TCL_VOLATILE);
2063: } else {
2064: Tcl_SetResult (interp, inet_ntoa (client -> peeraddr.sin_addr),
2065: TCL_VOLATILE);
2066: }
2067:
2068: return TCL_OK;
2069: }
2070:
2071: /*
2072: * tcpClientObjectServerCmd --
2073: *
2074: * This procedure is invoked in response to the `$client server'
2075: * Tcl command. It returns the name of the server to which the client
2076: * is connected.
2077: */
2078:
2079: static int
2080: tcpClientObjectServerCmd (clientData, interp, argc, argv)
2081: ClientData clientData;
2082: Tcl_Interp * interp;
2083: int argc;
2084: char * * argv;
2085: {
2086: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
2087:
2088: if (argc != 1) {
2089: Tcl_AppendResult (interp, "wrong # args: should be \"", argv [-1], " ",
2090: argv [0], "\"", (char *) NULL);
2091: return TCL_ERROR;
2092: }
2093:
2094: Tcl_SetResult (interp, client -> server -> name, TCL_STATIC);
2095:
2096: return TCL_OK;
2097: }
2098:
2099: /*
2100: * deleteTcpClientObjectCmd --
2101: *
2102: * This procedure is invoked when a client object's command has
2103: * been deleted. WARNING -- deleting a client object command when the
2104: * client is active is a FATAL error that cannot be reported through the
2105: * Tcl interpreter.
2106: *
2107: * This procedure does all the cleanup necessary to getting rid of the
2108: * client.
2109: */
2110:
2111: static void
2112: deleteTcpClientObjectCmd (clientData)
2113: ClientData clientData;
2114: {
2115: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
2116: register Tcp_ServerData * server = client -> server;
2117:
2118: /* Make sure the client is really dead. */
2119:
2120: if (client -> activeFlag) {
2121: fprintf (stderr, "attempt to delete an active TCP client!\n\n");
2122: abort ();
2123: }
2124:
2125: /* Remove any handler for data on the client's socket. */
2126:
2127: simpleDeleteFileHandler (client -> socketfd);
2128:
2129: /* Now it's safe to close the socket */
2130:
2131: (void) close (client -> socketfd);
2132:
2133: /* Get rid of the command */
2134:
2135: if (client -> command != NULL && client -> freeCommand != NULL) {
2136: (*(client -> freeCommand)) (client -> command);
2137: }
2138:
2139: /* Get rid of the input buffer */
2140:
2141: Tcl_DeleteCmdBuf (client -> inputBuffer);
2142:
2143: /* Get rid of any pending result */
2144:
2145: if (client -> resultString != NULL && client -> freeResultString != NULL) {
2146: (*(client -> freeResultString)) (client -> resultString);
2147: }
2148:
2149: /* Unlink the client from the list of active clients */
2150:
2151: if (client -> prev == NULL)
2152: client -> server -> firstClient = client -> next;
2153: else
2154: client -> prev -> next = client -> next;
2155:
2156: if (client -> next != NULL)
2157: client -> next -> prev = client -> prev;
2158:
2159: /* Now it's ok to destroy the client's data structure */
2160:
2161: ckfree ((char *) client);
2162:
2163: /* Handle a deferred close on the server if necessary */
2164:
2165: if (server -> stopFlag && server -> firstClient == NULL)
2166: tcpDeleteServer (server);
2167: }
2168:
2169: /*
2170: * tcpConnectionObjectCmd --
2171: *
2172: * This procedure is invoked to process the object command for a client-
2173: * side connection object. It takes a couple of diferent forms:
2174: *
2175: * $connection close
2176: * Closes the connection.
2177: * $connection send arg ?arg....?
2178: * Catenates the arguments into a Tcl command, and sends them
2179: * to the server.
2180: */
2181:
2182: static int
2183: tcpConnectionObjectCmd (clientData, interp, argc, argv)
2184: ClientData clientData;
2185: Tcl_Interp * interp;
2186: int argc;
2187: char * * argv;
2188: {
2189: unsigned length;
2190: int c;
2191: char * arg;
2192:
2193: if (argc < 2) {
2194: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [0], " ",
2195: "command ?args?\"", (char *) NULL);
2196: return TCL_ERROR;
2197: }
2198:
2199: arg = argv [1];
2200: c = arg [0];
2201: length = strlen (arg);
2202:
2203: if (c == 'c' && strncmp (arg, "close", length) == 0) {
2204: return tcpConnectionObjectCloseCmd (clientData, interp, argc-1, argv+1);
2205: }
2206: if (c == 's' && strncmp (arg, "send", length) == 0) {
2207: return tcpConnectionObjectSendCmd (clientData, interp, argc-1, argv+1);
2208: }
2209:
2210: Tcl_AppendResult (interp, "unknown command \"", arg,
2211: "\": must be close or send", (char *) NULL);
2212: return TCL_ERROR;
2213: }
2214:
2215: /*
2216: * tcpConnectionObjectCloseCmd --
2217: *
2218: * This procedure is invoked in response to a `close' command on a
2219: * client-side connection object. It closes the socket and deletes the
2220: * object command.
2221: */
2222:
2223: /* ARGSUSED */
2224: static int
2225: tcpConnectionObjectCloseCmd (clientData, interp, argc, argv)
2226: ClientData clientData;
2227: Tcl_Interp * interp;
2228: int argc;
2229: char * * argv;
2230: {
2231: if (argc != 1) {
2232: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [-1], " ",
2233: argv [0], "\"", (char *) NULL);
2234: return TCL_ERROR;
2235: }
2236:
2237: Tcl_DeleteCommand (interp, argv [-1]);
2238: return TCL_OK;
2239: }
2240:
2241: /*
2242: * tcpConnectionObjectSendCmd --
2243: *
2244: * This procedure is invoked in response to a `send' command on a client-
2245: * side connection object. It catenates the `send' arguments into a single
2246: * string, presents that string to the server as a command, and returns the
2247: * server's reply.
2248: */
2249:
2250: static int
2251: tcpConnectionObjectSendCmd (clientData, interp, argc, argv)
2252: ClientData clientData;
2253: Tcl_Interp * interp;
2254: int argc;
2255: char * * argv;
2256: {
2257: char * message;
2258: int f = (int) clientData;
2259: int status;
2260:
2261: if (argc < 2) {
2262: Tcl_AppendResult (interp, "wrong # args, should be \"", argv [-1], " ",
2263: argv [0], " command\"", (char *) NULL);
2264: return TCL_ERROR;
2265: }
2266:
2267: /* Paste together the message */
2268:
2269: message = Tcl_Merge (argc-1, argv+1);
2270:
2271: /* Send the command to the server */
2272:
2273: status = tcpSendCmdToServer (interp, f, message);
2274: if (status != TCL_OK)
2275: return status;
2276:
2277: /* Get the server's reply */
2278:
2279: return tcpReceiveResultFromServer (interp, f);
2280: }
2281:
2282: /*
2283: * deleteTcpConnectionObjectCmd --
2284: *
2285: * This procedure is called when a connection object is to be
2286: * deleted. It just has to close the socket that the object uses.
2287: */
2288:
2289: static void
2290: deleteTcpConnectionObjectCmd (clientData)
2291: ClientData clientData;
2292: {
2293: int f = (int) clientData;
2294: (void) close (f);
2295: }
2296:
2297: /*
2298: * tcpCloseClient --
2299: *
2300: * This procedure is called when the program is completely done with
2301: * a client object. If the `active' flag is set, there is still a reference
2302: * to the dead client, but we shouldn't have come here in that case.
2303: */
2304:
2305: static void
2306: tcpCloseClient (client)
2307: Tcp_ClientData * client;
2308: {
2309: if (client -> activeFlag)
2310: abort ();
2311:
2312: /* Deleting the client command is all we need to do -- the delete
2313: * procedure does everything else.
2314: */
2315:
2316: Tcl_DeleteCommand (client -> server -> interp, client -> name);
2317: }
2318:
2319: /*
2320: * tcpServerAcceptConnection --
2321: *
2322: * This procedure is invoked as a file handler whenever a server's
2323: * socket is ready for `reading' -- i.e., has a connection request
2324: * outstanding.
2325: *
2326: * It calls the `accept' command on the server to create a client.
2327: * If the `accept' is successful, it then calls the `do'
2328: * command on the client. If either call fails, a background error
2329: * is reported.
2330: */
2331:
2332: /* ARGSUSED */
2333: static void
2334: tcpServerAcceptConnection (clientData, mask)
2335: ClientData clientData;
2336: int mask;
2337: {
2338: register Tcp_ServerData * server = (Tcp_ServerData *) clientData;
2339:
2340: int status;
2341:
2342: char * clientName;
2343:
2344: /* Accept the connection with `$server accept' */
2345:
2346: status = Tcl_VarEval (server -> interp, server -> name, " accept",
2347: (char *) NULL);
2348:
2349: /* On success, try to execute the client's command with `$client do' */
2350:
2351: if (status == TCL_OK) {
2352: clientName = (char *) ckalloc (strlen (server -> interp -> result) + 1);
2353: strcpy (clientName, server -> interp -> result);
2354: status = Tcl_VarEval (server -> interp, clientName, " do", (char *) NULL);
2355:
2356: /* Client may have been closed at this point. Don't refer to it again. */
2357: }
2358:
2359: if (status != TCL_OK) {
2360: simpleReportBackgroundError (server -> interp);
2361: }
2362: Tcl_ResetResult (server -> interp);
2363: }
2364:
2365: /*
2366: * tcpTrustedHost --
2367: *
2368: * This procedure is invoked whenever the code must determine whether
2369: * a host is trusted. A host is considered trusted only if it is the local
2370: * host.
2371: *
2372: * Results:
2373: * Returns a Boolean value that is TRUE iff the host is trusted.
2374: */
2375:
2376: /* The HOSTCMP macro is just strcmp, but puts its args on stderr if
2377: * the DEBUG_TRUSTED_HOST flag is #define'd. It's used because this
2378: * code can be a little flaky; if `hostname' returns a name that is
2379: * completely unknown in the database, this macro will trace what happened.
2380: */
2381:
2382: #ifdef DEBUG_TRUSTED_HOST
2383: #define HOSTCMP( name1, name2 ) \
2384: (fprintf (stderr, "tcpTrustedHost: comparing %s with %s\n", \
2385: (name1), (name2)), \
2386: strcmp ((name1), (name2)))
2387: #else
2388: #define HOSTCMP( name1, name2 ) \
2389: strcmp ((name1), (name2))
2390: #endif
2391:
2392: static int
2393: tcpTrustedHost (hostName)
2394: char * hostName;
2395: {
2396: char localName [128];
2397: struct hostent * hostEnt;
2398: struct in_addr hostAddr;
2399: int unixStatus;
2400: int i;
2401:
2402: /* This procedure really has to do things the hard way. The problem is
2403: * that the hostname() kernel call returns the host name set by the system
2404: * administrator, which may not be the host's primary name as known to
2405: * the domain name system. Furthermore, the host presented may be one
2406: * of the names for the loopback port, 127.0.0.1, and this must be checked,
2407: * too.
2408: */
2409:
2410: /* Start assembling a list of possibilities for the host name. First
2411: * possibility is the name that the kernel returns as hostname ().
2412: */
2413:
2414: unixStatus = gethostname (localName, 127);
2415: if (unixStatus >= 0) {
2416:
2417: if (!HOSTCMP( hostName, localName )) return 1;
2418:
2419: /* Next possibility is a.b.c.d notation for all of the local addresses,
2420: * plus all the nicknames for the host.
2421: */
2422:
2423: hostEnt = gethostbyname (localName);
2424: if (hostEnt != (struct hostent *) NULL) {
2425: if (!HOSTCMP( hostName, hostEnt -> h_name )) return 1;
2426: if (hostEnt -> h_aliases != (char * *) NULL) {
2427: for (i = 0; hostEnt -> h_aliases [i] != (char *) NULL; ++i) {
2428: if (!HOSTCMP( hostName, hostEnt -> h_aliases [i] )) return 1;
2429: }
2430: }
2431: if (hostEnt -> h_addr_list != (char * *) NULL) {
2432: for (i = 0; hostEnt -> h_addr_list [i] != (char *) NULL; ++i) {
2433: /* note that the address doesn't have to be word-aligned (!) */
2434: memcpy ((char *) &hostAddr,
2435: hostEnt -> h_addr_list [i],
2436: hostEnt -> h_length);
2437: if (!HOSTCMP( hostName, inet_ntoa (hostAddr) )) return 1;
2438: }
2439: }
2440: }
2441: }
2442:
2443: /* Finally, there's the possibility of the loopback address, and all of
2444: * its aliases.*/
2445:
2446: if (!HOSTCMP( hostName, "0.0.0.0" )) return 1;
2447: if (!HOSTCMP( hostName, "127.0.0.1" )) return 1;
2448: hostAddr.s_addr = htonl (INADDR_LOOPBACK);
2449: hostEnt = gethostbyaddr ((char *) &hostAddr, sizeof hostAddr, AF_INET);
2450: if (hostEnt != (struct hostent *) NULL) {
2451: if (!HOSTCMP( hostName, hostEnt -> h_name )) return 1;
2452: if (hostEnt -> h_aliases != (char * *) NULL) {
2453: for (i = 0; hostEnt -> h_aliases [i] != (char *) NULL; ++i) {
2454: if (!HOSTCMP( hostName, hostEnt -> h_aliases [i] )) return 1;
2455: }
2456: }
2457: if (hostEnt -> h_addr_list != (char * *) NULL) {
2458: for (i = 0; hostEnt -> h_addr_list [i] != (char *) NULL; ++i) {
2459: /* note that the address doesn't have to be word-aligned (!) */
2460: memcpy ((char *) &hostAddr,
2461: hostEnt -> h_addr_list [i],
2462: hostEnt -> h_length);
2463: if (!HOSTCMP( hostName, inet_ntoa (hostAddr) )) return 1;
2464: }
2465: }
2466: }
2467:
2468: return 0;
2469: }
2470:
2471: /*
2472: * tcpReturnResultToClient --
2473: *
2474: * This procedure is invoked to return a result to a client. It
2475: * extracts the interpreter's result string, bundles it with the return
2476: * status, and stores it in the client's `resultString' area.
2477: *
2478: * It then calls tcpWriteResultToClient to try to start sending the
2479: * result.
2480: */
2481:
2482: static void
2483: tcpReturnResultToClient (client, interp, status, closeflag)
2484: Tcp_ClientData * client;
2485: Tcl_Interp * interp;
2486: int status;
2487: int closeflag;
2488: {
2489: char * argv [2];
2490: char rint [16];
2491: unsigned length;
2492: char * result;
2493:
2494: /* Put together a message comprising the return status and the interpreter
2495: * result */
2496:
2497: sprintf (rint, "%d", status);
2498: argv [0] = rint;
2499: argv [1] = interp -> result;
2500: result = Tcl_Merge (2, argv);
2501: length = strlen (result);
2502: client -> resultString = (char *) malloc (length + 2);
2503: strcpy (client -> resultString, result);
2504: strcpy (client -> resultString + length, "\n");
2505: free (result);
2506: client -> resultPointer = client -> resultString;
2507: client -> freeResultString = (Tcl_FreeProc *) free;
2508:
2509: Tcl_ResetResult (interp);
2510: client -> closeFlag |= closeflag;
2511:
2512: /* Now try to send the reply. */
2513:
2514: tcpWriteResultToClient ((ClientData) client, TK_WRITABLE);
2515:
2516: /* tcpWriteResultToClient closes the client if it fails; don't depend on
2517: * having the client still be usable. */
2518: }
2519:
2520: /*
2521: * tcpWriteResultToClient --
2522: *
2523: * This procedure is invoked to issue a write on a client socket.
2524: * It can be called directly by tcpReturnResultToClient, to attempt the
2525: * initial write of results. It can also be called as a file handler,
2526: * to retry a write that was previously blocked.
2527: */
2528:
2529: /* ARGSUSED */
2530: static void
2531: tcpWriteResultToClient (clientData, mask)
2532: ClientData clientData;
2533: int mask;
2534: {
2535: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
2536:
2537: int unixStatus;
2538: int length;
2539:
2540: length = strlen (client -> resultPointer);
2541:
2542: /* Issue the write */
2543:
2544: unixStatus = write (client -> socketfd, client -> resultPointer,
2545: length);
2546:
2547: /* Test for a total failure */
2548:
2549: if (unixStatus < 0) {
2550: if (errno != EWOULDBLOCK) {
2551: tcpClientWriteError (client);
2552: /* tcpClientWriteError closes the client as a side effect. Don't depend
2553: * on the client still being there.
2554: */
2555: return;
2556: } else {
2557: unixStatus = 0; /* Pretend that EWOULDBLOCK succeeded at
2558: * writing zero characters. */
2559: }
2560: }
2561:
2562: /* Test for a partial success */
2563:
2564: if (unixStatus < length) {
2565: client -> resultPointer += unixStatus;
2566: simpleCreateFileHandler (client -> socketfd, TK_WRITABLE,
2567: (Tk_FileProc *) tcpWriteResultToClient,
2568: clientData);
2569: }
2570:
2571: /* Total success -- prepare the client for the next input */
2572:
2573: else {
2574: if (client -> freeResultString != NULL) {
2575: (*(client -> freeResultString)) (client -> resultString);
2576: }
2577: client -> resultString = client -> resultPointer = (char *) NULL;
2578: client -> freeResultString = (Tcl_FreeProc *) NULL;
2579: simpleDeleteFileHandler (client -> socketfd);
2580: if (client -> closeFlag) {
2581: tcpCloseClient (client);
2582:
2583: /* After tcpCloseClient executes, the client goes away. Don't depend
2584: on it's still being there. */
2585:
2586: } else {
2587: tcpPrepareClientForInput (client);
2588: }
2589: }
2590: }
2591:
2592: /*
2593: * tcpPrepareClientForInput --
2594: *
2595: * This procedure is invoked to prepare a client to accept command
2596: * input. It establishes a handler, tcpReceiveClientInput, that does the
2597: * actual command buffering.
2598: */
2599:
2600: static void
2601: tcpPrepareClientForInput (client)
2602: Tcp_ClientData * client;
2603: {
2604: simpleCreateFileHandler (client -> socketfd, TK_READABLE,
2605: (Tk_FileProc *) tcpReceiveClientInput,
2606: (ClientData) client);
2607: }
2608:
2609: /*
2610: * tcpReceiveClientInput --
2611: *
2612: * This procedure is called when a server is awaiting input from a client
2613: * and the client socket tests to be `ready to read'. It reads a bufferload
2614: * of data from the client, and places it in the client's command buffer. If
2615: * the command is complete, it then tries to invoke the command.
2616: */
2617:
2618: /* ARGSUSED */
2619: static void
2620: tcpReceiveClientInput (clientData, mask)
2621: ClientData clientData;
2622: int mask;
2623: {
2624: register Tcp_ClientData * client = (Tcp_ClientData *) clientData;
2625: register Tcp_ServerData * server = client -> server;
2626: register Tcl_Interp * interp = server -> interp;
2627:
2628: static char buffer [BUFSIZ+1];
2629: int unixStatus;
2630: char * command;
2631: int status;
2632: char * docmd;
2633: char * argv [3];
2634: int argc;
2635: int i;
2636:
2637: /* Try to read from the client */
2638:
2639: errno = 0;
2640: unixStatus = read (client -> socketfd, buffer, BUFSIZ);
2641: if (unixStatus <= 0 && errno != EWOULDBLOCK)
2642: tcpClientReadError (client);
2643:
2644: /* tcpClientReadError closes the client and reports the error.
2645: In any case, if the read failed, we want to return. */
2646:
2647: if (unixStatus <= 0)
2648: return;
2649:
2650: if (server -> raw) {
2651: char buf[512];
2652:
2653: sprintf(buf, "RawInput %s %d %d", client -> name, buffer, unixStatus);
2654: printf("TCP executing: %s\n", buf);
2655: status = Tcl_Eval (interp, buf, 0, (char * *) NULL);
2656:
2657: tcpPrepareClientForInput (client);
2658:
2659: } else {
2660:
2661: /* Assemble the received data into the buffer */
2662:
2663: buffer [unixStatus] = '\0';
2664: command = Tcl_AssembleCmd (client -> inputBuffer, buffer);
2665: if (command != (char *) NULL) {
2666:
2667: /* Process the received command. */
2668:
2669: simpleDeleteFileHandler (client -> socketfd);
2670: argc = 3;
2671: argv [0] = client -> name;
2672: argv [1] = "do";
2673: argv [2] = command;
2674: docmd = Tcl_Merge (argc, argv);
2675: status = Tcl_Eval (interp, docmd, 0, (char * *) NULL);
2676: free (docmd);
2677:
2678: /* At this point, the client may have been closed. Don't try to
2679: refer to it. */
2680:
2681: if (status != TCL_OK) {
2682: simpleReportBackgroundError (interp);
2683: }
2684: }
2685: }
2686: }
2687:
2688: /* tcpClientReadError --
2689: *
2690: * This procedure is called when an attempt to read the command from a
2691: * client fails. There are two possibilities:
2692: *
2693: * The first is that there really was a read error, originating in the
2694: * socket system. In this case, the error should be reported at background
2695: * level, and the client should be closed.
2696: *
2697: * The second is that the read reached the end-of-information marker in
2698: * the client's stream. In this case, the `do' command should be called on
2699: * the client one last time, and then the client should be closed.
2700: *
2701: * If the application needs to clean the client up after a read error,
2702: * it must define the `tcperror' procedure and process the error.
2703: */
2704:
2705: static void
2706: tcpClientReadError (client)
2707: Tcp_ClientData * client;
2708: {
2709: Tcp_ServerData * server = client -> server;
2710: Tcl_Interp * interp = server -> interp;
2711: int status;
2712:
2713: if (errno != 0) {
2714:
2715: /* Read error */
2716:
2717: status = Tcl_VarEval (interp, "error {", client -> name, ": read error: ",
2718: Tcl_UnixError (interp), "}", (char *) NULL);
2719: simpleReportBackgroundError (interp);
2720:
2721: } else {
2722:
2723: /* End of file */
2724:
2725: status = Tcl_VarEval (interp, client -> name, " do", (char *) NULL);
2726: if (status != TCL_OK)
2727: simpleReportBackgroundError (interp);
2728: }
2729:
2730: tcpCloseClient (client);
2731: }
2732:
2733: /* tcpClientWriteError --
2734: *
2735: * This procedure is invoked when an attempt to return results to a client
2736: * has failed. It reports the error at background level and closes the client.
2737: *
2738: * If the application needs to clean up the client after a write error,
2739: * it must define the `tcperror' procedure to catch the error.
2740: */
2741:
2742: static void
2743: tcpClientWriteError (client)
2744: Tcp_ClientData * client;
2745: {
2746: Tcp_ServerData * server = client -> server;
2747: Tcl_Interp * interp = server -> interp;
2748:
2749: (void) Tcl_VarEval (interp, "error {", client -> name, ": read error: ",
2750: Tcl_UnixError (interp), "}", (char *) NULL);
2751: simpleReportBackgroundError (interp);
2752: tcpCloseClient (client);
2753: }
2754:
2755: /* tcpSendCmdToServer --
2756: *
2757: * This procedure is invoked to send a command originated by a client
2758: * using the `$connection send' Tcl command.
2759: *
2760: * The message is passed without a newline appended. The server requires
2761: * a newline, which is sent in a separate call.
2762: */
2763:
2764: static int
2765: tcpSendCmdToServer (interp, s, message)
2766: Tcl_Interp * interp;
2767: int s;
2768: char * message;
2769: {
2770: int length;
2771: int unixStatus;
2772: int rubbish;
2773: static char newline = '\n';
2774: void (*oldPipeHandler) ();
2775:
2776: /* Set the socket for blocking I/O */
2777:
2778: rubbish = 0;
2779: unixStatus = ioctl (s, FIONBIO, (char *) &rubbish);
2780: if (unixStatus < 0) {
2781: Tcl_AppendResult (interp, "can't set blocking I/O on socket: ",
2782: Tcl_UnixError (interp), (char *) NULL);
2783: return TCL_ERROR;
2784: }
2785:
2786: /* Keep a possible broken pipe from killing us silently */
2787:
2788: oldPipeHandler = signal (SIGPIPE, SIG_IGN);
2789:
2790: /* Write the message */
2791:
2792: length = strlen (message);
2793: unixStatus = write (s, message, length);
2794: if (unixStatus < length) {
2795: (void) signal (SIGPIPE, oldPipeHandler);
2796: Tcl_AppendResult (interp, "can't send message to server: ",
2797: Tcl_UnixError (interp), (char *) NULL);
2798: return TCL_ERROR;
2799: }
2800:
2801: /* Write the terminating newline */
2802:
2803: unixStatus = write (s, &newline, 1);
2804: if (unixStatus < 1) {
2805: (void) signal (SIGPIPE, oldPipeHandler);
2806: Tcl_AppendResult (interp, "can't send newline to server: ",
2807: Tcl_UnixError (interp), (char *) NULL);
2808: return TCL_ERROR;
2809: }
2810:
2811: (void) signal (SIGPIPE, oldPipeHandler);
2812: return TCL_OK;
2813: }
2814:
2815: /*
2816: * tcpReceiveResultFromServer --
2817: *
2818: * This procedure is invoked to get the result transmitted from
2819: * a remote server, either on establishing the connection or on processing
2820: * a command. It returns a standard Tcl result that is usually the result
2821: * returned by the server.
2822: */
2823:
2824: static int
2825: tcpReceiveResultFromServer (interp, s)
2826: Tcl_Interp * interp;
2827: int s;
2828: {
2829: int status;
2830: int unixStatus;
2831: int junk;
2832: Tcl_CmdBuf cmdbuf;
2833: struct timeval tick;
2834: struct timeval * tickp;
2835: fd_set readfds;
2836: char buf [BUFSIZ+1];
2837: char * reply;
2838: int rargc;
2839: char * * rargv;
2840: int rstatus;
2841:
2842: /* Read the result using non-blocking I/O */
2843:
2844: junk = 1;
2845: unixStatus = ioctl (s, FIONBIO, (char *) &junk);
2846: if (unixStatus < 0) {
2847: Tcl_AppendResult (interp, "can't set nonblocking I/O on socket: ",
2848: Tcl_UnixError (interp), (char *) NULL);
2849: return TCL_ERROR;
2850: }
2851:
2852: /* Make a buffer to receive the result */
2853:
2854: cmdbuf = Tcl_CreateCmdBuf ();
2855:
2856: /* Wait for the result to appear */
2857:
2858: tickp = (struct timeval *) 0;
2859: FD_ZERO( &readfds );
2860: FD_SET( s, &readfds );
2861: for ( ; ; ) {
2862:
2863: unixStatus = select (s + 1, &readfds, (fd_set *) NULL, (fd_set *) NULL,
2864: tickp);
2865:
2866: if (unixStatus < 0) {
2867: status = TCL_ERROR;
2868: Tcl_AppendResult (interp, "error selecting socket for reply: ",
2869: Tcl_UnixError (interp), (char *) NULL);
2870: break;
2871: }
2872:
2873: if (unixStatus == 0) {
2874: status = TCL_ERROR;
2875: Tcl_SetResult (interp, "timed out waiting for server reply", TCL_STATIC);
2876: break;
2877: }
2878:
2879: /* Read the result */
2880:
2881: unixStatus = read (s, buf, BUFSIZ);
2882:
2883: if (unixStatus < 0) {
2884: status = TCL_ERROR;
2885: Tcl_AppendResult (interp, "error reading server reply: ",
2886: Tcl_UnixError (interp), (char *) NULL);
2887: break;
2888: }
2889:
2890: if (unixStatus == 0) {
2891: status = TCL_ERROR;
2892: Tcl_SetResult (interp, "Connection closed.", TCL_STATIC);
2893: break;
2894: }
2895:
2896: /* Parse the (partial) command */
2897:
2898: buf [unixStatus] = '\0';
2899: reply = Tcl_AssembleCmd (cmdbuf, buf);
2900: if (reply != NULL) {
2901: status = TCL_OK;
2902: break;
2903: }
2904:
2905: /* Partial command not yet complete. Set timeout for reading the
2906: * rest of the result. */
2907:
2908: tick.tv_sec = 30;
2909: tick.tv_usec = 0;
2910: tickp = &tick;
2911: }
2912:
2913: /* When we come here, either the status is TCL_ERROR and the error
2914: * message is already set, or else the status is TCL_OK and `reply'
2915: * contains the result that we have to return. The first element of
2916: * `reply' has the status, and the second has the result string. */
2917:
2918: /* Split the list elements */
2919:
2920: if (status == TCL_OK) {
2921: status = Tcl_SplitList (interp, reply, &rargc, &rargv);
2922: if (status != TCL_OK) {
2923: Tcl_SetResult (interp, "server returned malformed list", TCL_STATIC);
2924: status = TCL_ERROR;
2925: }
2926: }
2927:
2928: /* Verify the element count */
2929:
2930: if (status == TCL_OK) {
2931: if (rargc != 2) {
2932: Tcl_SetResult (interp, "server returned malformed list", TCL_STATIC);
2933: status = TCL_ERROR;
2934: free ((char *) rargv);
2935: } else {
2936: status = Tcl_GetInt (interp, rargv [0], &rstatus);
2937: if (status != TCL_OK) {
2938: Tcl_SetResult (interp, "server returned unrecognizable status",
2939: TCL_STATIC);
2940: status = TCL_ERROR;
2941: free ((char *) rargv);
2942: }
2943: }
2944: }
2945:
2946: /* Return the result reported by the server */
2947:
2948: if (status == TCL_OK) {
2949: Tcl_SetResult (interp, rargv [1], TCL_VOLATILE);
2950: status = rstatus;
2951: free ((char *) rargv);
2952: }
2953:
2954: Tcl_DeleteCmdBuf (cmdbuf);
2955: return status;
2956: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.