]> git.zerfleddert.de Git - micropolis/blame_incremental - src/tk/tktcp.c
projects / micropolis / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
show less event history on small screens
[micropolis] / src / tk / tktcp.c
... / ...
CommitLineData
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
11static 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
49static 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
100extern int accept _ANSI_ARGS_((int, struct sockaddr *, int *));
101extern int bind _ANSI_ARGS_((int, const struct sockaddr *, int));
102extern int close _ANSI_ARGS_((int));
103extern int connect _ANSI_ARGS_((int, const struct sockaddr *, int));
104extern int gethostname _ANSI_ARGS_((char *, int));
105extern int getsockname _ANSI_ARGS_((int, struct sockaddr *, int *));
106extern int ioctl _ANSI_ARGS_((int, int, char *));
107extern int listen _ANSI_ARGS_((int, int));
108extern int read _ANSI_ARGS_((int, char *, int));
109extern int select _ANSI_ARGS_((int, fd_set *, fd_set *, fd_set *,
110 struct timeval *));
111extern int socket _ANSI_ARGS_((int, int, int));
112extern int getdtablesize _ANSI_ARGS_((void));
113
114\f
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
133typedef 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
163typedef 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
205static char * tcpCurrentClient = NULL;
206 /* The name of the client for which a */
207 /* command is being processed. */
208static Tcp_ServerData * tcpFirstServer = NULL;
209 /* Pointer to the first in a list of */
210 /* servers active in the current process. */
211\f
212/* Declarations for static functions within this file. */
213
214/* Static procedures in this file */
215
216static void simpleDeleteFileHandler1 _ANSI_ARGS_((ClientData, int));
217
218static void simpleDeleteFileHandler2 _ANSI_ARGS_((ClientData));
219
220static int
221tcpClientCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
222 int argc, char * * argv));
223
224static int
225tcpConnectCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
226 int argc, char * * argv));
227
228static int
229tcpEvalCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
230 int argc, char * * argv));
231
232static int
233tcpLoginCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
234 int argc, char * * argv));
235
236static int
237tcpMainLoopCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
238 int argc, char * * argv));
239
240static int
241tcpPollCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
242 int argc, char * * argv));
243
244static int
245tcpServerCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
246 int argc, char * * argv));
247
248static int
249tcpServersCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
250 int argc, char * * argv));
251static int
252tcpWaitCommand _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
253 int argc, char * * argv));
254
255static int
256tcpServerObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
257 int argc, char * * argv));
258static void
259deleteTcpServerObjectCmd _ANSI_ARGS_((ClientData clientData));
260
261static int
262tcpServerObjectAcceptCmd _ANSI_ARGS_((ClientData clientData,
263 Tcl_Interp * interp, int argc,
264 char * * argv));
265
266static int
267tcpServerObjectClientsCmd _ANSI_ARGS_((ClientData clientData,
268 Tcl_Interp * interp, int argc,
269 char * * argv));
270
271static int
272tcpServerObjectConfigCmd _ANSI_ARGS_((ClientData clientData,
273 Tcl_Interp * interp, int argc,
274 char * * argv));
275
276static int
277tcpServerObjectStartCmd _ANSI_ARGS_((ClientData clientData,
278 Tcl_Interp * interp, int argc,
279 char * * argv));
280
281static int
282tcpServerObjectStopCmd _ANSI_ARGS_((ClientData clientData,
283 Tcl_Interp * interp, int argc,
284 char * * argv));
285
286static void
287tcpDeleteServer _ANSI_ARGS_((Tcp_ServerData * server));
288
289static int
290tcpServerObjectConfig _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
291 int argc, char * * argv));
292
293static int
294tcpClientObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
295 int argc, char * * argv));
296
297static int
298tcpClientObjectCloseCmd _ANSI_ARGS_((ClientData clientData,
299 Tcl_Interp * interp,
300 int argc, char * * argv));
301
302static int
303tcpClientObjectCommandCmd _ANSI_ARGS_((ClientData clientData,
304 Tcl_Interp * interp,
305 int argc, char * * argv));
306
307static int
308tcpClientObjectDoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp,
309 int argc, char * * argv));
310
311static int
312tcpClientObjectHostnameCmd _ANSI_ARGS_((ClientData clientData,
313 Tcl_Interp * interp,
314 int argc, char * * argv));
315
316static int
317tcpClientObjectServerCmd _ANSI_ARGS_((ClientData clientData,
318 Tcl_Interp * interp,
319 int argc, char * * argv));
320
321static void
322deleteTcpClientObjectCmd _ANSI_ARGS_((ClientData clientData));
323
324static int
325tcpConnectionObjectCmd _ANSI_ARGS_((ClientData clientData,
326 Tcl_Interp * interp,
327 int argc, char * * argv));
328
329static int
330tcpConnectionObjectCloseCmd _ANSI_ARGS_((ClientData clientData,
331 Tcl_Interp * interp,
332 int argc, char * * argv));
333
334static int
335tcpConnectionObjectSendCmd _ANSI_ARGS_((ClientData clientData,
336 Tcl_Interp * interp,
337 int argc, char * * argv));
338
339static void
340deleteTcpConnectionObjectCmd _ANSI_ARGS_((ClientData clientData));
341
342static void
343tcpServerAcceptConnection _ANSI_ARGS_((ClientData clientData, int mask));
344
345static void
346tcpReturnResultToClient _ANSI_ARGS_((Tcp_ClientData * client,
347 Tcl_Interp * interp,
348 int status, int closeflag));
349
350static void
351tcpWriteResultToClient _ANSI_ARGS_((ClientData clientData, int mask));
352
353static void
354tcpClientReadError _ANSI_ARGS_((Tcp_ClientData * client));
355
356static void
357tcpClientWriteError _ANSI_ARGS_((Tcp_ClientData * client));
358
359static void
360tcpPrepareClientForInput _ANSI_ARGS_((Tcp_ClientData * client));
361
362static void
363tcpReceiveClientInput _ANSI_ARGS_((ClientData clientData, int mask));
364
365static void
366tcpCloseClient _ANSI_ARGS_((Tcp_ClientData * client));
367
368static int
369tcpTrustedHost _ANSI_ARGS_((char * hostname));
370
371static int
372tcpSendCmdToServer _ANSI_ARGS_((Tcl_Interp * interp, int s, char * message));
373
374static int
375tcpReceiveResultFromServer _ANSI_ARGS_((Tcl_Interp * interp, int s));
376\f
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
387void
388simpleReportBackgroundError (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\
434Tcl interpreter detected a background error.\n\
435Original error:\n\
436%s\n\
437\n\
438User \"bgerror\" procedure failed to handle the background error.\n\
439Error 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\f
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
473void
474simpleCreateFileHandler (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\f
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
506void
507simpleDeleteFileHandler (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 */
520static void
521simpleDeleteFileHandler1 (clientData, mask)
522 ClientData clientData;
523 int mask;
524{
525 (void) fprintf (stderr, "in simpleDeleteFileHandler1: bug in tkEvent.c");
526 abort ();
527}
528
529static void
530simpleDeleteFileHandler2 (clientData)
531 ClientData clientData;
532{
533 int fd = (int) clientData;
534
535 Tk_DeleteFileHandler (fd);
536}
537\f
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
571int
572Tk_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\f
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 */
637static int
638tcpClientCommand (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\f
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 */
671static int
672tcpConnectCommand (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\f
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 */
770static int
771tcpEvalCommand (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\f
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*/
821static int
822tcpLoginCommand (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\f
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*/
891static int
892tcpMainLoopCommand (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\f
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*/
936static int
937tcpPollCommand (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\f
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 */
999static int
1000tcpServerCommand (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\f
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 */
1107static int
1108tcpServersCommand (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\f
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*/
1147static int
1148tcpWaitCommand (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\f
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
1203static int
1204tcpServerObjectCmd (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\f
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
1261static int
1262tcpServerObjectAcceptCmd (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\f
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
1362static int
1363tcpServerObjectClientsCmd (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\f
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
1400static int
1401tcpServerObjectConfigCmd (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\f
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
1492static int
1493tcpServerObjectStartCmd (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\f
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
1543static int
1544tcpServerObjectStopCmd (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\f
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
1582static void
1583deleteTcpServerObjectCmd (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\f
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
1636static void
1637tcpDeleteServer (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\f
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
1681static int
1682tcpServerObjectConfig (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\f
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
1823static int
1824tcpClientObjectCmd (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\f
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
1872static int
1873tcpClientObjectCloseCmd (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\f
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
1907static int
1908tcpClientObjectCommandCmd (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\f
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 */
1960static int
1961tcpClientObjectDoCmd (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\f
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
2040static int
2041tcpClientObjectHostnameCmd (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\f
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
2079static int
2080tcpClientObjectServerCmd (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\f
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
2111static void
2112deleteTcpClientObjectCmd (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\f
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
2182static int
2183tcpConnectionObjectCmd (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\f
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 */
2224static int
2225tcpConnectionObjectCloseCmd (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\f
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
2250static int
2251tcpConnectionObjectSendCmd (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\f
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
2289static void
2290deleteTcpConnectionObjectCmd (clientData)
2291 ClientData clientData;
2292{
2293 int f = (int) clientData;
2294 (void) close (f);
2295}
2296\f
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
2305static void
2306tcpCloseClient (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\f
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 */
2333static void
2334tcpServerAcceptConnection (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\f
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
2392static int
2393tcpTrustedHost (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\f
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
2482static void
2483tcpReturnResultToClient (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\f
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 */
2530static void
2531tcpWriteResultToClient (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\f
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
2600static void
2601tcpPrepareClientForInput (client)
2602 Tcp_ClientData * client;
2603{
2604 simpleCreateFileHandler (client -> socketfd, TK_READABLE,
2605 (Tk_FileProc *) tcpReceiveClientInput,
2606 (ClientData) client);
2607}
2608\f
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 */
2619static void
2620tcpReceiveClientInput (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);
2654printf("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\f
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
2705static void
2706tcpClientReadError (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\f
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
2742static void
2743tcpClientWriteError (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\f
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
2764static int
2765tcpSendCmdToServer (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\f
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
2824static int
2825tcpReceiveResultFromServer (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}
Micropolis
Impressum, Datenschutz