Index: unix/tclUnixSock.c ================================================================== --- unix/tclUnixSock.c +++ unix/tclUnixSock.c @@ -125,10 +125,13 @@ Tcl_Interp *interp); static int TcpClose2Proc(ClientData instanceData, Tcl_Interp *interp, int flags); static int TcpGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); +static int TcpSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); static int TcpGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static int TcpInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); @@ -148,11 +151,11 @@ TCL_CHANNEL_VERSION_5, /* v5 channel */ TcpCloseProc, /* Close proc. */ TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ + TcpSetOptionProc, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Initialize notifier. */ TcpGetHandleProc, /* Get OS handles out of channel. */ TcpClose2Proc, /* Close2 proc. */ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ @@ -749,10 +752,38 @@ } /* *---------------------------------------------------------------------- * + * TcpSetOptionProc -- + * + * Sets Tcp channel specific options. + * + * Results: + * None, unless an error happens. + * + * Side effects: + * Changes attributes of the socket at the system level. + * + *---------------------------------------------------------------------- + */ + +static int +TcpSetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to set. */ + const char *value) /* New value for option. */ +{ + TcpState *statePtr = instanceData; + + return Tcl_BadChannelOption(interp, optionName, ""); +} + +/* + *---------------------------------------------------------------------- + * * TcpGetOptionProc -- * * Computes an option value for a TCP socket based channel, or a list of * all options and their values. * @@ -912,11 +943,11 @@ } /* *---------------------------------------------------------------------- * - * TcpWatchProc -- + * WrapNotify -- * * Initialize the notifier to watch the fd from this channel. * * Results: * None. Index: win/tclWinSock.c ================================================================== --- win/tclWinSock.c +++ win/tclWinSock.c @@ -246,10 +246,12 @@ static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); +static int GetSocketError(TcpState *statePtr); + static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); @@ -1121,10 +1123,11 @@ ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to set. */ const char *value) /* New value for option. */ { + TcpState *statePtr = instanceData; #ifdef TCL_FEATURE_KEEPALIVE_NAGLE TcpState *statePtr = instanceData; SOCKET sock; #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ @@ -1139,10 +1142,97 @@ Tcl_SetObjResult(interp, Tcl_NewStringObj( "winsock is not initialized", -1)); } return TCL_ERROR; } + + /* + * Go one step in async connect + * If any error is thrown save it as backround error to report eventually below + */ + WaitForConnect(statePtr, NULL); + + /* + * Option -error otherVar: Return socket error and socket error dict (TIP 428) + */ + if (!strcmp(optionName, "-error")) { + + Tcl_Obj *errorDictPtr; + + /* + * Get error code and clear it + */ + int errorCode=GetSocketError(statePtr); + + /* + * Check for interpreter - otherwise we can not output + */ + if (!interp) { + return TCL_OK; + } + + /* + * Clear any existing result + */ + Tcl_ResetResult(interp); + + /* + * Write -code key to dictionary with value 0/1 + */ + errorDictPtr = Tcl_NewDictObj(); + if ( TCL_ERROR == Tcl_DictObjPut(interp, errorDictPtr, + Tcl_NewStringObj("-code",-1), Tcl_NewBooleanObj(errorCode)) ) { + return TCL_ERROR; + } + + if (0 != errorCode) { + + /* + * Add key -errorcode with list value: POSIX id message + */ + Tcl_Obj *errorMessagePtr; + Tcl_Obj *valuePtr = Tcl_NewObj(); + errorMessagePtr = Tcl_NewStringObj(Tcl_ErrnoMsg(errorCode),-1); + Tcl_SetErrno(errorCode); + if (TCL_ERROR == Tcl_ListObjAppendElement(interp, valuePtr, + Tcl_NewStringObj("POSSIX",-1)) || + TCL_ERROR == Tcl_ListObjAppendElement(interp, valuePtr, + Tcl_NewStringObj(Tcl_ErrnoId(),-1)) || + TCL_ERROR == Tcl_ListObjAppendElement(interp, valuePtr, + errorMessagePtr)) { + return TCL_ERROR; + } + + if ( TCL_ERROR == Tcl_DictObjPut(interp, errorDictPtr, + Tcl_NewStringObj("-errorcode",-1), valuePtr) ) { + return TCL_ERROR; + } + + /* + * Set the result to the error message (shared with last list + * member of the -errorcode value). + */ + Tcl_SetObjResult(interp,errorMessagePtr); + } + + /* + * Save to specified variable + */ + if ( NULL == + Tcl_SetVar2Ex(interp, value, NULL, errorDictPtr, TCL_LEAVE_ERR_MSG )) + { + /* + * Setting variable failed. This may also due to a variable name issue + * like an existing array with the same name. + * Thus treat this gracefully and clear temporary memory. + */ + Tcl_DecrRefCount(errorDictPtr); + return TCL_ERROR; + } + + return TCL_OK; + } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" sock = statePtr->sockets->fd; @@ -1190,13 +1280,13 @@ return TCL_ERROR; } return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); + return Tcl_BadChannelOption(interp, optionName, "error keepalive nagle"); #else - return Tcl_BadChannelOption(interp, optionName, ""); + return Tcl_BadChannelOption(interp, optionName, "error"); #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } /* *---------------------------------------------------------------------- @@ -1263,60 +1353,18 @@ if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { /* - * Do not return any errors if async connect is running - */ - if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { - - - if ( statePtr->flags & TCP_ASYNC_FAILED ) { - - /* - * In case of a failed async connect, eventually report the - * connect error only once. - * Do not report the system error, as this comes again and again. - */ - - if ( statePtr->connectError != 0 ) { - Tcl_DStringAppend(dsPtr, - Tcl_ErrnoMsg(statePtr->connectError), -1); - statePtr->connectError = 0; - } - - } else { - - /* - * Report an eventual last error of the socket system - */ - - int optlen; - int ret; - DWORD err; - - /* - * Populater the err Variable with a possix error - */ - optlen = sizeof(int); - ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - /* - * The error was not returned directly but should be - * taken from WSA - */ - if (ret == SOCKET_ERROR) { - err = WSAGetLastError(); - } - /* - * Return error message - */ - if (err) { - TclWinConvertError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); - } - } + * Get error code and clear it + */ + int errorCode=GetSocketError(statePtr); + /* + * Return error message + */ + if (errorCode != 0) { + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errorCode), -1); } return TCL_OK; } if ((len > 1) && (optionName[1] == 'c') && @@ -1507,10 +1555,79 @@ #endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * GetSocketError -- + * + * Get the error code for fconfigure -error. + * + * Results: + * error code. + * + * Side effects: + * Resets the error state. + * + *---------------------------------------------------------------------- + */ + +static int +GetSocketError( + TcpState *statePtr) /* The socket state. */ +{ + int errorCode = 0; + + /* + * Do not return any errors if async connect is running + */ + if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { + return 0; + } + if ( statePtr->flags & TCP_ASYNC_FAILED ) { + + /* + * In case of a failed async connect, eventually report the + * connect error only once. + * Do not report the system error, as this comes again and again. + */ + + errorCode = statePtr->connectError; + statePtr->connectError = 0; + } else { + + /* + * Report an eventual last error of the socket system + */ + + int optlen; + int ret; + DWORD err; + + /* + * Populater the err Variable with a possix error + */ + optlen = sizeof(int); + ret = getsockopt(statePtr->sockets->fd, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + /* + * The error was not returned directly but should be + * taken from WSA + */ + if (ret == SOCKET_ERROR) { + err = WSAGetLastError(); + } + if (err) { + TclWinConvertError(err); + errorCode = Tcl_GetErrno(); + } + } + return errorCode; +} /* *---------------------------------------------------------------------- * * TcpWatchProc --