A simple TCP connect for TCL/TK (source included)
Pekka Nikander
Below you will find a simple TCL/TK TCP "connect" command. This one is
IMHO somewhat simpler and maybe a little bit more integrated to Tcl
than the other two TCP packages posted so far. The code creates two
new TCL commands, "connect" (Tcp_ConnectCmd) and "filehander"
(Tcp_FileHandlerCmd). The "filehandler" command is only available
with Tk.
The "connect" command is used to open a connection to a TCP port on
some host. The command returns an standard TCL open file descriptor
(as would be returned by TCL "open" command). Thus, when the socket
is open it can be handled with standard TCL "read", "puts", "close"
etc. However, there is a bug in Tcl_ReadCmd (TCL6.2) so that reading
from a socket always stops even when there is data available. The
code below includes a patch for this. I don't know if the patch
breaks something else, but I don't think so.
The "filehandler" command is used on an open file descriptor. It
defines a TCL command that will be called whenever the file descriptor
can be read, written and/or there is an exceptional condition. See
the manual page for more information.
Pekka Nikander Internet: p...@ajk.tele.fi -or-
Telecom Finland Pekka.N...@ajk.tele.fi
----------------------------------------------------------------
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: tcpConnect.c doc/Connect.man tclUnixAZ-diff
# Wrapped by p...@innopoli.ajk.tele.fi on Sun Mar 22 21:34:53 1992
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f tcpConnect.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tcpConnect.c\"
else
echo shar: Extracting \"tcpConnect.c\" \(9162 characters\)
sed "s/^X//" >tcpConnect.c <<'END_OF_tcpConnect.c'
X/*
X * tcpConnect.c --
X *
X * This file contains a simple Tcl "connect" command
X * that returns an standard Tcl File descriptor (as would
X * be returned by Tcl_OpenCmd).
X *
X * Author: Pekka Nikander <p...@innopoli.ajk.tele.fi>
X *
X * Copyright 1992 Telecom Finland
X *
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that this copyright
X * notice appears in all copies. Telecom Finland
X * makes no representations about the suitability of this
X * software for any purpose. It is provided "as is" without
X * express or implied warranty.
X *
X * Created: Sun Mar 22 18:20:29 1992
X * Last modified: Sun Mar 22 21:34:31 1992 pnr
X */
X
X#ifndef lint
Xstatic char rcsid[] = "...";
X#endif /* not lint */
X
X#include "tclInt.h"
X#include "tclUnix.h"
X
X#include <assert.h>
X#include <string.h>
X#include <sys/types.h>
X#include <sys/socket.h>
X#include <netinet/in.h>
X#include <netdb.h>
X#include <arpa/inet.h>
X
X#ifdef USE_TK
X#include <tk.h>
X#endif /* USE_TK */
X
Xstatic FILE *fconnect _ANSI_ARGS_((char *host, char *port));
Xstatic void HandleSocket _ANSI_ARGS_ ((ClientData clientData, int mask));
X
X#ifdef USE_TK
Xtypedef struct {
X Tcl_Interp *interp;
X OpenFile *filePtr;
X char *tclCmd;
X char *fileId;
X} FileCmd;
X#endif /* USE_TK */
X
X/*
X *------------------------------------------------------------------
X *
X * Tcp_ConnectCmd --
X *
X * Open a socket connection to a given host and service.
X *
X * Results:
X * A standard Tcl result.
X *
X * Side effects:
X * An open socket connection.
X *------------------------------------------------------------------
X */
X
X/* ARGSUSED */
Xint
XTcp_ConnectCmd(notUsed, interp, argc, argv)
X ClientData notUsed;
X Tcl_Interp *interp;
X int argc;
X char **argv;
X{
X Interp *iPtr = (Interp *) interp;
X register OpenFile *filePtr;
X int fd;
X
X if (argc != 3) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " host port\"", (char *) NULL);
X return TCL_ERROR;
X }
X
X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
X filePtr->f = NULL;
X filePtr->f2 = NULL;
X filePtr->readable = 0;
X filePtr->writable = 0;
X filePtr->numPids = 0;
X filePtr->pidPtr = NULL;
X filePtr->errorId = -1;
X
X /*
X * Create the connection
X */
X filePtr->f = fconnect(argv[1], argv[2]);
X if (filePtr->f == NULL) {
X Tcl_AppendResult(interp, "couldn't open connection to \"",
X argv[1], "\" port \"", argv[2], "\": ",
X Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X setbuf(filePtr->f, (char *) NULL);
X
X filePtr->readable = 1;
X filePtr->writable = 1;
X
X /*
X * Enter this new OpenFile structure in the table for the
X * interpreter. May have to expand the table to do this.
X */
X
X fd = fileno(filePtr->f);
X TclMakeFileTable(iPtr, fd);
X if (iPtr->filePtrArray[fd] != NULL) {
X panic("Tcl_OpenCmd found file already open");
X }
X iPtr->filePtrArray[fd] = filePtr;
X sprintf(interp->result, "file%d", fd);
X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------
X *
X * fconnect --
X *
X * Create a FILE * connection to given host and port.
X *
X * Results:
X * An open FILE* or NULL.
X *
X * Side effects:
X * None.
X *----------------------------------------------------------------
X */
X
Xstatic FILE*
Xfconnect(host, service)
X char *host; /* Host to connect, name or IP address */
X char *service; /* Port to use, service name or port number */
X{
X struct hostent *hostent, _hostent;
X struct servent *servent, _servent;
X struct protoent *protoent;
X struct sockaddr_in sockaddr;
X int sock, status;
X int hostaddr, hostaddrPtr[2];
X int servport;
X extern int errno;
X
X hostent = gethostbyname(host);
X if (hostent == NULL) {
X hostaddr = inet_addr(host);
X if (hostaddr == -1) {
X errno = EINVAL;
X return NULL;
X }
X _hostent.h_addr_list = (char **)hostaddrPtr;
X _hostent.h_addr_list[0] = (char *)&hostaddr;
X _hostent.h_addr_list[1] = NULL;
X _hostent.h_length = sizeof(hostaddr);
X _hostent.h_addrtype = AF_INET;
X hostent = &_hostent;
X }
X servent = getservbyname(service, "tcp");
X if (servent == NULL) {
X servport = atoi(service);
X if (servport == -1) {
X errno = EINVAL;
X return NULL;
X }
X _servent.s_port = servport;
X _servent.s_proto = "tcp";
X servent = &_servent;
X }
X protoent = getprotobyname(servent->s_proto);
X if (protoent == NULL) {
X errno = EINVAL;
X return NULL;
X }
X
X sock = socket(PF_INET, SOCK_STREAM, protoent->p_proto);
X if (sock < 0) {
X return NULL;
X }
X
X sockaddr.sin_family = AF_INET;
X memcpy((char *)&(sockaddr.sin_addr.s_addr),
X (char *) hostent->h_addr_list[0],
X (size_t) hostent->h_length);
X sockaddr.sin_port = servent->s_port;
X
X status = connect(sock, (struct sockaddr *) &sockaddr, sizeof(sockaddr));
X
X if (status < 0) {
X close (sock);
X return NULL;
X }
X
X return fdopen(sock, "r+");
X}
X
X#ifdef USE_TK
X
X/*
X *----------------------------------------------------------------
X *
X * Tcp_FileHandlerCmd --
X *
X * Register a file handler with an open file. If there is
X * already and existing handler, it will be no longer called.
X * If no mask and command are given, any existing handler
X * will be deleted.
X *
X * Results:
X * A standard Tcl result. (Always OK).
X *
X * Side effects:
X * A new file handler is associated with a give TCL open file.
X * Whenever the file is readable, writeable and/or there is
X * an expection condition on the file, a user supplied TCL
X * command is called.
X *
X *----------------------------------------------------------------
X */
X
Xint
XTcp_FileHandlerCmd(notUsed, interp, argc, argv)
X ClientData notUsed;
X Tcl_Interp *interp;
X int argc;
X char **argv;
X{
X FileCmd *cmdPtr;
X OpenFile *filePtr;
X int mask;
X
X if (argc != 2 && argc != 4) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " fileId ?mode command?\"", (char *) NULL);
X return TCL_ERROR;
X }
X
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X
X if (argc == 2) {
X /*
X * NOTE! Currently the cmdPtr structure will be left
X * *unfreed* if the file handler is deleted
X * via this code. Tough. Would need a hash table
X * or something...
X */
X Tk_DeleteFileHandler(fileno(filePtr->f));
X return TCL_OK;
X }
X
X mask = 0;
X if (strchr(argv[2], 'r')) {
X mask |= TK_READABLE;
X }
X if (strchr(argv[2], 'w')) {
X mask |= TK_WRITABLE;
X }
X if (strchr(argv[2], 'e')) {
X mask |= TK_EXCEPTION;
X }
X if (mask == 0 || (strlen(argv[2]) != strspn(argv[2], "rwe"))) {
X Tcl_AppendResult(interp, "bad mask argument \"", argv[2],
X "\": should be any combination of \"r\", \"w\" and \"e\"",
X (char *) NULL);
X fclose(filePtr->f);
X return TCL_ERROR;
X }
X
X cmdPtr = (FileCmd *)ckalloc(sizeof(FileCmd));
X cmdPtr->interp = interp;
X cmdPtr->filePtr = filePtr;
X cmdPtr->tclCmd = ckalloc(strlen(argv[3]) + 1);
X strcpy(cmdPtr->tclCmd, argv[3]);
X cmdPtr->fileId = ckalloc(strlen(argv[1]) + 1);
X strcpy(cmdPtr->fileId, argv[1]);
X
X Tk_CreateFileHandler(fileno(filePtr->f), mask, HandleSocket, cmdPtr);
X
X return TCL_OK;
X}
X/*
X *----------------------------------------------------------------
X *
X * HandleSocket --
X *
X * This procedure is called from Tk_DoOneEvent whenever there is
X * a desired condition on a given open socket. An Tcl command
X * given by the user is executed to handle the connection. If
X * and EOF or ERROR condition is noticed, all memory resources
X * associated with the socket are released and the socket is closed.
X *
X * Results:
X * None.
X *
X * Side effects:
X * The user supplied command can do anything.
X *
X *----------------------------------------------------------------
X */
X
Xstatic void
XHandleSocket(clientData, mask)
X ClientData clientData;
X int mask;
X{
X int result;
X FileCmd *cmdPtr = (FileCmd *) clientData;
X OpenFile *filePtr = cmdPtr->filePtr;
X Tcl_Interp *interp = cmdPtr->interp;
X OpenFile *dummy;
X int delete;
X int fd = fileno(filePtr->f);
X
X Tk_Preserve(cmdPtr);
X
X if (mask & TK_EXCEPTION) {
X result = Tcl_VarEval(interp, cmdPtr->tclCmd, " e ", cmdPtr->fileId,
X (char *) NULL);
X if (result != TCL_OK) {
X TkBindError(interp);
X }
X }
X if (mask & TK_READABLE) {
X result = Tcl_VarEval(interp, cmdPtr->tclCmd, " r ", cmdPtr->fileId,
X (char *) NULL);
X if (result != TCL_OK) {
X TkBindError(interp);
X }
X }
X if (mask & TK_WRITABLE) {
X result = Tcl_VarEval(interp, cmdPtr->tclCmd, " w ", cmdPtr->fileId,
X (char *) NULL);
X if (result != TCL_OK) {
X TkBindError(interp);
X }
X }
X
X delete = 0;
X if (TclGetOpenFile(interp, cmdPtr->fileId, &dummy) != TCL_OK) {
X /* Already closed */
X Tcl_ResetResult(interp);
X delete = 1;
X } else {
X if (feof(filePtr->f) || ferror(filePtr->f)) {
X result = Tcl_VarEval(interp, "close ", cmdPtr->fileId);
X if (result != TCL_OK) {
X TkBindError(interp);
X }
X delete = 1;
X }
X }
X
X Tk_Release(cmdPtr);
X
X if (delete) {
X Tk_DeleteFileHandler(fd);
X Tk_EventuallyFree(cmdPtr, free);
X }
X}
X
X#endif /* USE_TK */
END_OF_tcpConnect.c
if test 9162 -ne `wc -c <tcpConnect.c`; then
echo shar: \"tcpConnect.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f Connect.man -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"Connect.man\"
else
echo shar: Extracting \"Connect.man\" \(6654 characters\)
sed "s/^X//" >Connect.man <<'END_OF_Connect.man'
X'\"
X'\" Copyright 1989 Regents of the University of California
X'\" Permission to use, copy, modify, and distribute this
X'\" documentation for any purpose and without fee is hereby
X'\" granted, provided that this notice appears in all copies.
X'\" The University of California makes no representations about
X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/man/RCS/Tcl.man,v 1.89 91/12/20 09:49:44 ouster Exp $ SPRITE (Berkeley)
X'
X.\" The definitions below are for supplemental macros used in Sprite
X.\" manual entries.
X.\"
X.\" .HS name section [date [version]]
X.\" Replacement for .TH in other man pages. See below for valid
X.\" section names.
X.\"
X.\" .AP type name in/out [indent]
X.\" Start paragraph describing an argument to a library procedure.
X.\" type is type of argument (int, etc.), in/out is either "in", "out",
X.\" or "in/out" to describe whether procedure reads or modifies arg,
X.\" and indent is equivalent to second arg of .IP (shouldn't ever be
X.\" needed; use .AS below instead)
X.\"
X.\" .AS [type [name]]
X.\" Give maximum sizes of arguments for setting tab stops. Type and
X.\" name are examples of largest possible arguments that will be passed
X.\" to .AP later. If args are omitted, default tab stops are used.
X.\"
X.\" .BS
X.\" Start box enclosure. From here until next .BE, everything will be
X.\" enclosed in one large box.
X.\"
X.\" .BE
X.\" End of box enclosure.
X.\"
X.\" .VS
X.\" Begin vertical sidebar, for use in marking newly-changed parts
X.\" of man pages.
X.\"
X.\" .VE
X.\" End of vertical sidebar.
X.\"
X.\" .DS
X.\" Begin an indented unfilled display.
X.\"
X.\" .DE
X.\" End of indented unfilled display.
X.\"
X' # Heading for Sprite man pages
X.de HS
X.if '\\$2'cmds' .TH \\$1 1 \\$3 \\$4
X.if '\\$2'lib' .TH \\$1 3 \\$3 \\$4
X.if '\\$2'tcl' .TH \\$1 3 \\$3 \\$4
X.if '\\$2'tk' .TH \\$1 3 \\$3 \\$4
X.if t .wh -1.3i ^B
X.nr ^l \\n(.l
X.ad b
X..
X' # Start an argument description
X.de AP
X.ie !"\\$4"" .TP \\$4
X.el \{\
X. ie !"\\$2"" .TP \\n()Cu
X. el .TP 15
X.\}
X.ie !"\\$3"" \{\
X.ta \\n()Au \\n()Bu
X\&\\$1 \\fI\\$2\\fP (\\$3)
X.\".b
X.\}
X.el \{\
X.br
X.ie !"\\$2"" \{\
X\&\\$1 \\fI\\$2\\fP
X.\}
X.el \{\
X\&\\fI\\$1\\fP
X.\}
X.\}
X..
X' # define tabbing values for .AP
X.de AS
X.nr )A 10n
X.if !"\\$1"" .nr )A \\w'\\$1'u+3n
X.nr )B \\n()Au+15n
X.\"
X.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
X.nr )C \\n()Bu+\\w'(in/out)'u+2n
X..
X' # BS - start boxed text
X' # ^y = starting y location
X' # ^b = 1
X.de BS
X.br
X.mk ^y
X.nr ^b 1u
X.if n .nf
X.if n .ti 0
X.if n \l'\\n(.lu\(ul'
X.if n .fi
X..
X' # BE - end boxed text (draw box now)
X.de BE
X.nf
X.ti 0
X.mk ^t
X.ie n \l'\\n(^lu\(ul'
X.el \{\
X.\" Draw four-sided box normally, but don't draw top of
X.\" box if the box started on an earlier page.
X.ie !\\n(^b-1 \{\
X\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
X.\}
X.el \}\
X\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
X.\}
X.\}
X.fi
X.br
X.nr ^b 0
X..
X' # VS - start vertical sidebar
X' # ^Y = starting y location
X' # ^v = 1 (for troff; for nroff this doesn't matter)
X.de VS
X.mk ^Y
X.ie n 'mc \s12\(br\s0
X.el .nr ^v 1u
X..
X' # VE - end of vertical sidebar
X.de VE
X.ie n 'mc
X.el \{\
X.ev 2
X.nf
X.ti 0
X.mk ^t
X\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
X.sp -1
X.fi
X.ev
X.\}
X.nr ^v 0
X..
X' # Special macro to handle page bottom: finish off current
X' # box/sidebar if in box/sidebar mode, then invoked standard
X' # page bottom macro.
X.de ^B
X.ev 2
X'ti 0
X'nf
X.mk ^t
X.if \\n(^b \{\
X.\" Draw three-sided box if this is the box's first page,
X.\" draw two sides but no top otherwise.
X.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
X.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
X.\}
X.if \\n(^v \{\
X.nr ^x \\n(^tu+1v-\\n(^Yu
X\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
X.\}
X.bp
X'fi
X.ev
X.if \\n(^b \{\
X.mk ^y
X.nr ^b 2
X.\}
X.if \\n(^v \{\
X.mk ^Y
X.\}
X..
X' # DS - begin display
X.de DS
X.RS
X.nf
X.sp
X..
X' # DE - end display
X.de DE
X.fi
X.RE
X.sp .5
X..
X.de UL
X\\$1\l'|0\(ul'\\$2
X..
X.HS Tcl tcl
X.BS
X.SH NAME
Xconnect, filehandler \- Opens and handles TCP connections
X.BE
X.TP
X\fBconnect \fIhost\fR \fIport\fR
XConnects to a server with TCP and returns an identifier that may be
Xused in future invocations of commands like \fBread\fR, \fBwrite\fR,
Xand \fBclose\fR. \fIhost\fR gives the name of the host to connect to.
X\fIport\fR gives the desired port.
X
XEven if every socket is opened for both reading and writing, \fBseek\fR
Xmust not be invoked between a read and a write.
X.TP
X\fBfilehandler \fIfile\fR ?\fImode\fR \fIcommand\fR?
XThe \fBfilehander\fR command is only used with Tk. The command
Xspecifies a TCL command to be called whenever the given \fIfile\fR can
Xbe read, written, and/or when there is an exeptional condition. The
X\fImode\fR argument indicates the situations when the \fIcommand\fR
Xwill be called. It may be any combination of the following values:
X.RS
X.TP
X\fBr\fR
XCall \fIcommand\fR whenever the there is data to read from the socket.
XThe command procedure is called with two arguemnts: \fBr\fR to
Xindicate that there is something to read, and a \fIfile\fR id
Xthat can be used for reading. The procedure should read at least some
Xdata from the socket, or otherwise the procedure will be called
Xcontinuously.
X.TP
X\fBw\fR
XCall \fIcommand\fR whenever data can be written to the socket. This
Xoption is rarely used since most sockets can be written most of the time.
X.TP
X\fBe\fR
XCall \fIcommand\fR whenever there is an exceptional condition pending
Xon the socket. The \fIcommand\fR procedure is called with two
Xarguments: an \fBe\fR to indicate exception, and a \fIfile\fR id that
Xcan be used as an argument to \fBread\fR, \fBclose\fR etc.
X.PP
XThe same \fIcommand\fR may be used for several different conditions.
XThe first argument supplied to \fIcommand\fR denotes always the
Xcondition type. If there are several different conditions (e.g. the
Xfile can be both read and written), the \fIcommand\fR will be called
Xseparately for each condition.
X
XSpecifying a new command with \fBfilehandler\fR will remove any
Xearlier command from use. NOTE! Currently there is a small memory
Xleak whenever a new command replaces an existing one.
X
XWhen a \fIcommand\fR procedure is specified for the socket via
X\fBfilehandler\fR command, the socket will be automatically closed and the
Xassociated file handler deleted if there is a pending eof or error
Xcondition after executing the user supplied \fIcommand\fR procedure.
X.SH AUTHOR
XPekka Nikander, Telecom Finland (Pekka.N...@ajk.tele.fi)
END_OF_Connect.man
if test 6654 -ne `wc -c <Connect.man`; then
echo shar: \"Connect.man\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tclUnixAZ-diff -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tclUnixAZ-diff\"
else
echo shar: Extracting \"tclUnixAZ-diff\" \(742 characters\)
sed "s/^X//" >tclUnixAZ-diff <<'END_OF_tclUnixAZ-diff'
X*** tclUnixAZ.c.orig Sun Jan 5 01:25:44 1992
X--- tclUnixAZ.c Sun Mar 22 20:09:37 1992
X***************
X*** 1306,1312 ****
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X! numBytes = statBuf.st_size - ftell(filePtr->f) + 1;
X if (argc > 2) {
X if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
X newline = 0;
X--- 1306,1316 ----
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X! numBytes = statBuf.st_size;
X! if (ftell(filePtr->f) > 0) {
X! /* ftell may return EOF on sockets, pipes etc. in SunOS */
X! numBytes -= ftell(filePtr->f);
X! }
X if (argc > 2) {
X if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
X newline = 0;
END_OF_tclUnixAZ-diff
if test 742 -ne `wc -c <tclUnixAZ-diff`; then
echo shar: \"tclUnixAZ-diff\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of shell archive.
exit 0
--
Pekka Nikander Internet: p...@ajk.tele.fi -or-
Telecom Finland Pekka.N...@ajk.tele.fi