Posted to tcl by colin at Tue Nov 01 02:45:06 GMT 2011view raw
- # UDP an extension to provide minimal UDP support to Tcl using direct events for reception
- package provide Udp 1.0
- package require critcl
- critcl::config outdir .
- #namespace import critcl::*
- critcl::ccode {
- /* UDP client in the internet domain */
- #include <sys/types.h>
- #include <sys/socket.h>
- #include <netinet/in.h>
- #include <arpa/inet.h>
- #include <netdb.h>
- #include <stdio.h>
- #include <stdlib.h>
- #include <unistd.h>
- #include <string.h>
- #include <tcl.h>
- #include <errno.h>
- static char errBuf[256];
- /*
- * This structure describes per-instance state
- * of a udp channel.
- *
- */
- typedef struct udpState {
- int sock; /* inderlying (tcp) file descriptor */
- Tcl_Obj *script; /* script prefix for incoming */
- Tcl_Interp *interp; /* interp this was instantiated in */
- Tcl_Channel chan; /* associate chan */
- int addr; /* local bound address */
- uint16_t port; /* local bound port */
- int multicast; /* indicator set for multicast add */
- Tcl_Obj *groupsObj; /* list of the mcast groups */
- } UdpState;
- /* ----------------------------------------------------------------------
- *
- * LSearch --
- *
- * Find a string item in a list and return the index of -1.
- */
- static int
- LSearch(Tcl_Obj *listObj, const char *group)
- {
- int objc, n;
- Tcl_Obj **objv;
- Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
- for (n = 0; n < objc; n++) {
- if (strcmp(group, Tcl_GetString(objv[n])) == 0) {
- return n;
- }
- }
- return -1;
- }
- /*
- * ----------------------------------------------------------------------
- *
- * UdpMulticast --
- *
- * Action should be IP_ADD_MEMBERSHIP | IP_DROP_MEMBERSHIP
- *
- */
- static int
- UdpMulticast(ClientData instanceData, Tcl_Interp *interp,
- const char *grp, int action)
- {
- UdpState *statePtr = (UdpState *)instanceData;
- struct ip_mreq mreq;
- struct hostent *name;
- memset(&mreq, 0, sizeof(mreq));
- mreq.imr_multiaddr.s_addr = inet_addr(grp);
- if (mreq.imr_multiaddr.s_addr == -1) {
- name = gethostbyname(grp);
- if (name == NULL) {
- Tcl_SetResult(interp, "invalid group name", TCL_STATIC);
- return TCL_ERROR;
- }
- memcpy(&mreq.imr_multiaddr.s_addr, name->h_addr,
- sizeof(mreq.imr_multiaddr));
- }
- mreq.imr_interface.s_addr = INADDR_ANY;
- if (setsockopt(statePtr->sock, IPPROTO_IP, action,
- (const char*)&mreq, sizeof(mreq)) < 0) {
- Tcl_SetResult(interp, "error changing multicast group", TCL_STATIC);
- return TCL_ERROR;
- }
- if (action == IP_ADD_MEMBERSHIP) {
- int ndx = LSearch(statePtr->groupsObj, grp);
- if (ndx == -1) {
- statePtr->multicast++;
- Tcl_ListObjAppendElement(interp, statePtr->groupsObj,
- Tcl_NewStringObj(grp,-1));
- }
- } else {
- int ndx = LSearch(statePtr->groupsObj, grp);
- if (ndx != -1) {
- Tcl_Obj *old, *ptr;
- int dup = 0;
- old = ptr = statePtr->groupsObj;
- statePtr->multicast--;
- if ((dup = Tcl_IsShared(ptr))) {
- ptr = Tcl_DuplicateObj(ptr);
- }
- Tcl_ListObjReplace(interp, ptr, ndx, 1, 0, NULL);
- if (dup) {
- statePtr->groupsObj = ptr;
- Tcl_IncrRefCount(ptr);
- Tcl_DecrRefCount(old);
- }
- }
- }
- if (interp != NULL)
- Tcl_SetObjResult(interp, statePtr->groupsObj);
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpClose --
- *
- * This function is invoked by the generic IO level to perform
- * channel-type-specific cleanup when a UDP socket based channel is
- * closed.
- *
- * Results:
- * 0 if successful, the value of errno if failed.
- *
- * Side effects:
- * Closes the socket of the channel.
- *
- *----------------------------------------------------------------------
- */
- static int udpClose(
- ClientData instanceData, /* The socket to close. */
- Tcl_Interp *interp) /* For error reporting - unused. */
- {
- int objc;
- Tcl_Obj **objv;
- int errorCode = 0;
- UdpState *state = (UdpState *) instanceData;
- /*
- * If there are multicast groups added they should be dropped.
- */
- if (state->groupsObj) {
- int n = 0;
- Tcl_ListObjGetElements(interp, state->groupsObj, &objc, &objv);
- for (n = 0; n < objc; n++) {
- UdpMulticast((ClientData)state, interp,
- Tcl_GetString(objv[n]), IP_DROP_MEMBERSHIP);
- }
- Tcl_DecrRefCount(state->groupsObj);
- }
- if (close(state->sock) < 0) {
- errorCode = Tcl_GetErrno();
- }
- ckfree((char*)state);
- return errorCode;
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpInput --
- *
- * This function is invoked by the generic IO level to read input from a
- * UDP socket based channel. It is meaningless for UDP
- *
- * Results: EINVAL
- *
- *----------------------------------------------------------------------
- */
- static int
- udpInput(
- ClientData instanceData, /* Socket state. */
- char *buf, /* Where to store data read. */
- int bufSize, /* How much space is available in the buffer? */
- int *errorCodePtr) /* Where to store error code. */
- {
- *errorCodePtr = EINVAL;
- return -1;
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpOutput --
- *
- * This function is invoked by the generic IO level to write output to a
- * UDP socket based channel. It is meaningless for UDP.
- *
- * Results: EINVAL
- *
- *----------------------------------------------------------------------
- */
- static int
- udpOutput(
- ClientData instanceData, /* Socket state. */
- const char *buf, /* The data buffer. */
- int toWrite, /* How many bytes to write? */
- int *errorCodePtr) /* Where to store error code. */
- {
- *errorCodePtr = EINVAL;
- return -1;
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpGetOption --
- *
- * Computes an option value for a UDP socket based channel, or a list of
- * all options and their values.
- *
- * Note: This code is based on code contributed by John Haxby.
- *
- * Results:
- * A standard Tcl result. The value of the specified option or a list of
- * all options and their values is returned in the supplied DString. Sets
- * Error message if needed.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
- static int
- udpGetOption(ClientData instanceData, Tcl_Interp *interp,
- char *optionName, Tcl_DString *optionValue)
- {
- UdpState *statePtr = (UdpState *)instanceData;
- CONST84 char * options[] = { "myport", "mcastgroups", "broadcast", "ttl", NULL};
- int r = TCL_OK;
- if (optionName == NULL) {
- Tcl_DString ds;
- const char **p;
- Tcl_DStringInit(&ds);
- for (p = options; *p != NULL; p++) {
- char op[16];
- sprintf(op, "-%s", *p);
- Tcl_DStringSetLength(&ds, 0);
- udpGetOption(instanceData, interp, op, &ds);
- Tcl_DStringAppend(optionValue, " ", 1);
- Tcl_DStringAppend(optionValue, op, -1);
- Tcl_DStringAppend(optionValue, " ", 1);
- Tcl_DStringAppendElement(optionValue, Tcl_DStringValue(&ds));
- }
- } else {
- Tcl_DString ds, dsInt;
- Tcl_DStringInit(&ds);
- Tcl_DStringInit(&dsInt);
- if (!strcmp("-myport", optionName)) {
- Tcl_DStringSetLength(&ds, TCL_INTEGER_SPACE);
- sprintf(Tcl_DStringValue(&ds), "%u", ntohs(statePtr->port));
- } else if (!strcmp("-mcastgroups", optionName)) {
- int objc, n;
- Tcl_Obj **objv;
- Tcl_ListObjGetElements(interp, statePtr->groupsObj, &objc, &objv);
- for (n = 0; n < objc; n++) {
- Tcl_DStringAppendElement(&ds, Tcl_GetString(objv[n]));
- }
- } else if (!strcmp("-broadcast", optionName)) {
- int tmp = 1;
- socklen_t optlen = sizeof(int);
- if (getsockopt(statePtr->sock, SOL_SOCKET, SO_BROADCAST,
- (char *)&tmp, &optlen)) {
- /*UDPTRACE("UDP error - getsockopt\n");*/
- Tcl_SetResult(interp, "error in getsockopt", TCL_STATIC);
- r = TCL_ERROR;
- } else {
- Tcl_DStringSetLength(&ds, TCL_INTEGER_SPACE);
- sprintf(Tcl_DStringValue(&ds), "%d", tmp);
- }
- } else if (!strcmp("-ttl", optionName)) {
- unsigned int tmp = 0;
- socklen_t optlen = sizeof(unsigned int);
- int cmd = IP_TTL;
- if (statePtr->multicast > 0)
- cmd = IP_MULTICAST_TTL;
- if (getsockopt(statePtr->sock, IPPROTO_IP, cmd,
- (char *)&tmp, &optlen)) {
- /*UDPTRACE("UDP error - getsockopt");*/
- Tcl_SetResult(interp, "error in getsockopt", TCL_STATIC);
- r = TCL_ERROR;
- } else {
- Tcl_DStringSetLength(&ds, TCL_INTEGER_SPACE);
- sprintf(Tcl_DStringValue(&ds), "%u", tmp);
- }
- } else {
- CONST84 char **p;
- Tcl_DString tmp;
- Tcl_DStringInit(&tmp);
- for (p = options; *p != NULL; p++)
- Tcl_DStringAppendElement(&tmp, *p);
- r = Tcl_BadChannelOption(interp, optionName, Tcl_DStringValue(&tmp));
- Tcl_DStringFree(&tmp);
- }
- if (r == TCL_OK) {
- Tcl_DStringAppend(optionValue, Tcl_DStringValue(&ds), -1);
- }
- Tcl_DStringFree(&dsInt);
- Tcl_DStringFree(&ds);
- }
- return r;
- }
- /*
- * ----------------------------------------------------------------------
- * udpGetService --
- *
- * Return the service port number in network byte order from either a
- * string representation of the port number or the service name. If the
- * service string cannot be converted (ie: a name not present in the
- * services database) then set a Tcl error.
- * ----------------------------------------------------------------------
- */
- static int
- udpGetService(Tcl_Interp *interp, const char *service,
- unsigned short *servicePort)
- {
- struct servent *sv = NULL;
- char *remainder = NULL;
- int r = TCL_OK;
- sv = getservbyname(service, "udp");
- if (sv != NULL) {
- *servicePort = sv->s_port;
- } else {
- *servicePort = htons((unsigned short)strtol(service, &remainder, 0));
- if (remainder == service) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "invalid service name: \"", service,
- "\" could not be converted to a port number",
- TCL_STATIC);
- r = TCL_ERROR;
- }
- }
- return r;
- }
- /*
- * ----------------------------------------------------------------------
- * udpSetOption --
- *
- * Handle channel configuration requests from the generic layer.
- *
- * ----------------------------------------------------------------------
- */
- static int
- udpSetOption(ClientData instanceData, Tcl_Interp *interp,
- char *optionName, char *newValue)
- {
- UdpState *statePtr = (UdpState *)instanceData;
- char * options = "remote mcastadd mcastdrop broadcast ttl";
- int r = TCL_OK;
- if (!strcmp("-mcastadd", optionName)) {
- r = UdpMulticast(instanceData, interp,
- (const char *)newValue, IP_ADD_MEMBERSHIP);
- } else if (!strcmp("-mcastdrop", optionName)) {
- r = UdpMulticast(instanceData, interp,
- (const char *)newValue, IP_DROP_MEMBERSHIP);
- } else if (!strcmp("-broadcast", optionName)) {
- int tmp = 1;
- r = Tcl_GetInt(interp, newValue, &tmp);
- if (r == TCL_OK) {
- if (setsockopt(statePtr->sock, SOL_SOCKET, SO_BROADCAST,
- (const char *)&tmp, sizeof(int))) {
- /*sprintf(errBuf, "%s", "udp - setsockopt");
- UDPTRACE("UDP error - setsockopt\n");*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(errBuf, -1));
- r = TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(tmp));
- }
- }
- } else if (!strcmp("-ttl", optionName)) {
- unsigned int tmp = 0;
- int cmd = IP_TTL;
- if (statePtr->multicast > 0)
- cmd = IP_MULTICAST_TTL;
- r = Tcl_GetInt(interp, newValue, &tmp);
- if (r == TCL_OK) {
- if (setsockopt(statePtr->sock, IPPROTO_IP, cmd,
- (const char *)&tmp, sizeof(unsigned int))) {
- /*sprintf(errBuf, "udp - setsockopt ttl");
- UDPTRACE("UDP error - setsockopt\n");*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj(errBuf, -1));
- r = TCL_ERROR;
- } else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(tmp));
- }
- }
- } else {
- r = Tcl_BadChannelOption(interp, optionName, options);
- }
- return r;
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpNotifyChannel --
- *
- * This procedure is called by a channel driver when a driver detects an
- * event on a channel. This procedure is responsible for actually
- * handling the event by invoking any channel handler callbacks.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Whatever the channel handler callback procedure does.
- *
- *----------------------------------------------------------------------
- */
- void
- udpNotifyChannel(
- UdpState *state, /* Channel that detected an event. */
- int mask) /* OR'ed combination of TCL_READABLE,
- * TCL_WRITABLE, or TCL_EXCEPTION: indicates
- * which events were detected. */
- {
- int n,s;
- Tcl_Obj *result = Tcl_DuplicateObj(state->script);
- Tcl_Interp *interp = state->interp;
- struct sockaddr_in from;
- socklen_t fromlen;
- char buf[1024];
- //fprintf(stderr, "Notify %p\n", state);
- fromlen = sizeof(struct sockaddr_in);
- n = recvfrom(state->sock,buf,1024,0,(struct sockaddr *)&from,&fromlen);
- if (n < 0) {
- /* error in reception - got to report */
- Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(Tcl_ErrnoMsg(Tcl_GetErrno()), -1));
- } else {
- Tcl_ListObjAppendElement(interp, result, Tcl_NewByteArrayObj(buf, n));
- Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(ntohl(from.sin_addr.s_addr)));
- Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(ntohs(from.sin_port)));
- }
- Tcl_EvalObjEx(interp, result, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpWatch --
- *
- * Initialize the notifier to watch the sock from this channel.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets up the notifier so that a future event on the channel will be
- * seen by Tcl.
- *
- *----------------------------------------------------------------------
- */
- static void
- udpWatch(
- ClientData instanceData, /* The socket state. */
- int mask) /* Events of interest; an OR-ed combination of
- * TCL_READABLE, TCL_WRITABLE and
- * TCL_EXCEPTION. */
- {
- UdpState *state = (UdpState *) instanceData;
- Tcl_CreateFileHandler(state->sock, mask,
- (Tcl_FileProc *) udpNotifyChannel,
- (ClientData) state);
- }
- /*
- *----------------------------------------------------------------------
- *
- * udpGetHandle --
- *
- * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a
- * UDP socket based channel.
- *
- * Results: EINVAL
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
- static int
- udpGetHandle(
- ClientData instanceData, /* The socket state. */
- int direction, /* Not used. */
- ClientData *handlePtr) /* Where to store the handle. */
- {
- UdpState *state = (UdpState *) instanceData;
- return state->sock;
- }
- static Tcl_ChannelType udp_chantype = {
- "udp", /* Type name. */
- NULL, /* Set blocking/nonblocking behaviour. NULL'able */
- udpClose, /* Close channel, clean instance data */
- udpInput, /* Handle read request */
- udpOutput, /* Handle write request */
- NULL, /* Move location of access point. NULL'able */
- udpSetOption, /* Set options. NULL'able */
- udpGetOption, /* Get options. NULL'able */
- udpWatch, /* Initialize notifier */
- udpGetHandle, /* Get OS handle from the channel. */
- };
- }
- namespace eval ::udp {
- critcl::ccommand create {clientdata interp objc objv} {
- int length;
- static int udp_count = 0;
- char channelName[24];
- struct sockaddr_in addr;
- UdpState *state = (UdpState *) Tcl_Alloc((unsigned) sizeof(UdpState));
- Tcl_Channel chan;
- state->interp = interp;
- state->sock = socket(AF_INET, SOCK_DGRAM, 0);
- state->groupsObj = Tcl_NewListObj(0, NULL);
- #if HAVE_FLAG_FD_CLOEXEC
- fcntl(state->sock, F_SETFD, FD_CLOEXEC);
- #endif
- if (state->sock < 0) {
- Tcl_AppendResult(interp, "Opening udp socket \"", Tcl_ErrnoMsg(Tcl_GetErrno()), "\"", NULL);
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- //fprintf(stderr, "create %p\n", state);
- if (objc > 1) {
- /* get port */
- state->port = 0;
- if (udpGetService(interp, Tcl_GetStringFromObj(objv[1], NULL), &state->port) != TCL_OK) {
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- //fprintf(stderr, "PORT:%d %x\n", state->port, state->port);
- if (objc == 4) {
- /* set address and script */
- const char *host = Tcl_GetStringFromObj(objv[2], NULL);
- struct hostent *hp = gethostbyname(host);
- if (hp == 0) {
- Tcl_AppendResult(interp, "Host unknown \"", Tcl_ErrnoMsg(Tcl_GetErrno()), "\"", NULL);
- close(state->sock);
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- bcopy((char *)hp->h_addr, (char *)&state->addr, hp->h_length);
- state->script = Tcl_DuplicateObj(objv[3]); /* record script prefix */
- } else if (objc == 3) {
- /* set script */
- state->addr = INADDR_ANY;
- state->script = Tcl_DuplicateObj(objv[2]); /* record script prefix */
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "udp create port ?addr? script");
- close(state->sock);
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- length = sizeof(addr);
- bzero(&addr,length);
- addr.sin_family=AF_INET;
- addr.sin_addr.s_addr=state->addr;
- addr.sin_port=state->port;
- if (bind(state->sock,(struct sockaddr *)&addr,length)<0) {
- Tcl_AppendResult(interp, "Bind \"", Tcl_ErrnoMsg(Tcl_GetErrno()), "\"", (char *) NULL);
- close(state->sock);
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- /* generate events on socket readable */
- //fprintf(stderr, "HANDLER %x %x\n", state->addr, state->port);
- Tcl_CreateFileHandler(state->sock, TCL_READABLE,
- (Tcl_FileProc *) udpNotifyChannel,
- (ClientData) state);
- //fprintf(stderr, "script %p '%s'\n", state->script, Tcl_GetString(state->script));
- }
- sprintf(channelName, "udp_%d", udp_count++);
- chan = Tcl_CreateChannel(&udp_chantype, channelName, (ClientData)state, 0);
- if (chan == (Tcl_Channel)NULL) {
- close(state->sock);
- Tcl_Free((char*)state);
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(interp, chan);
- state->chan = chan;
- Tcl_SetResult(interp, channelName, TCL_VOLATILE);
- return TCL_OK;
- }
- critcl::cproc send {Tcl_Interp* interp char* udp char* destination long port Tcl_Obj* dgram} ok {
- int n, dglen;
- char *dgb;
- Tcl_Channel chan = Tcl_GetChannel(interp, udp, NULL); /* The channel to send on. */
- struct sockaddr_in addr;
- struct hostent *hp;
- long length;
- UdpState *state;
- if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
- }
- state = Tcl_GetChannelInstanceData(chan);
- //fprintf(stderr, "send 1 %p\n", state);
- hp = gethostbyname(destination);
- if (hp==0) {
- Tcl_AppendResult(interp, "Unknown host \"", destination, "\"",
- (char *) NULL);
- return TCL_ERROR;
- }
- //fprintf(stderr, "send 2 %p\n", hp);
- bcopy((char *)hp->h_addr, (char *)&addr.sin_addr, hp->h_length);
- addr.sin_port = htons(port);
- addr.sin_family = AF_INET;
- length=sizeof(struct sockaddr_in);
- //fprintf(stderr, "send 3 %p\n", hp);
- dgb = Tcl_GetByteArrayFromObj(dgram, &dglen);
- //fprintf(stderr, "send 4 %p\n", dgb);
- n=sendto(state->sock, dgb, dglen, 0, (const struct sockaddr *)&addr, length);
- //fprintf(stderr, "send 5 %d\n", n);
- if (n != dglen) {
- Tcl_AppendResult(interp, "sendto error \"", Tcl_ErrnoMsg(Tcl_GetErrno()), "\"", (char *) NULL);
- return TCL_ERROR;
- }
- //fprintf(stderr, "send 6 %d\n", n);
- return TCL_OK;
- }
- }