ADDED .fossil-settings/manifest Index: .fossil-settings/manifest ================================================================== --- /dev/null +++ .fossil-settings/manifest @@ -0,0 +1,1 @@ +u Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,12 @@ +TclTLS 1.7.22 +========== + +Release Date: Mon Oct 12 15:40:16 CDT 2020 + +https://tcltls.rkeene.org/ + 2015-05-01 Andreas Kupries * configure.in: Bump to version 1.6.5. * win/makefile.vc: * configure: regen with ac-2.59 @@ -23,21 +30,21 @@ * win/makefile.vc: * configure: regen with ac-2.59 * tls.c (MiscObjCmd): Fixed non-static string array used in call of Tcl_GetIndexFromObj(). Memory smash waiting to happen. Thanks - to Brian Griffin for alerting us all to the problem. + to Brian Griffin for alerting us all to the problem. 2012-06-01 Andreas Kupries * tls.c: Applied Jeff's patch from http://www.mail-archive.com/aolserver@listserv.aol.com/msg12356.html * configure.in: Bump to version 1.6.2. * win/makefile.vc: * configure: regen with ac-2.59 - + 2010-08-11 Jeff Hobbs *** TLS 1.6.1 TAGGED *** * configure: regen with ac-2.59 @@ -101,11 +108,11 @@ * win/makefile.vc: with MSVC8 * win/rules.vc: 2007-06-22 Jeff Hobbs - * tlsIO.c (TlsInputProc, TlsOutputProc, TlsWatchProc): + * tlsIO.c (TlsInputProc, TlsOutputProc, TlsWatchProc): * tls.c (VerifyCallback): add an state flag in the verify callback that prevents possibly recursion (on 'update'). [Bug 1652380] * tests/ciphers.test: reworked to make test output cleaner to understand missing ciphers (if any) @@ -113,11 +120,11 @@ * Makefile.in, tclconfig/tcl.m4: update to TEA 3.6 * configure, configure.in: using autoconf-2.59 2007-02-28 Pat Thoyts - * win/makefile.vc: Rebase the DLL sensibly. Additional libs for + * win/makefile.vc: Rebase the DLL sensibly. Additional libs for static link of openssl. * tls.tcl: bug #1579837 - TIP 278 bug (possibly) - fixed. 2006-03-30 Pat Thoyts @@ -135,19 +142,19 @@ build directory. 2004-12-22 Pat Thoyts * configure.in: Incremented minor version to 1.5.1 - * configure: + * configure: 2004-12-17 Pat Thoyts * win/makefile.vc: Added the MSVC build system (from the Tcl * win/rules.vc: sampleextension). * win/nmakehlp.c: * win/tls.rc Added Windows resource file. - + * tls.tcl: From patch #948155, added support for alternate socket commands. * tls.c: Quieten some MSVC warnings. Prefer ckalloc over Tcl_Alloc. (David Graveraux). @@ -180,11 +187,11 @@ * tclconfig/README.txt, tclconfig/install-sh, tclconfig/tcl.m4: 2004-03-17 Dan Razzell * tlsX509.c: Add support for long serial numbers per RFC 3280. - Format is now hexadecimal. + Format is now hexadecimal. [Request #915313] Correctly convert certificate Distinguished Names to Tcl string representation. Eliminates use of deprecated OpenSSL function. Format is now compliant with RFC 2253. [Request #915315] @@ -231,11 +238,11 @@ * tls.c (Tls_Init): added tls::misc command provided by * tlsX509.c: Wojciech Kocjan (wojciech kocjan.org) * tests/keytest1.tcl: to expose more low-level SSL commands * tests/keytest2.tcl: -2003-05-15 Dan Razzell +2003-05-15 Dan Razzell * tls.tcl: * tlsInt.h: * tls.c: add support for binding a password callback to the socket. Now each socket can have its own command and password callbacks instead @@ -370,11 +377,11 @@ loaded into. TLS will fail the test suite with Tcl 8.2-8.3.1. * tests/all.tcl: added catch around ::tcltest::normalizePath because it doesn't exist in pre-8.3 tcltest. - * tests/simpleClient.tcl: + * tests/simpleClient.tcl: * tests/simpleServer.tcl: added simple client/server test scripts that use test certs and can do simple stress tests. 2000-08-14 Jeff Hobbs @@ -473,11 +480,11 @@ 2000-06-05 Scott Stanton * Makefile.in: Fixed broken test target. - * tlsInt.h: + * tlsInt.h: * tls.c: Cleaned up declarations of Tls_Clean to avoid errors on Windows (lint). 2000-06-05 Brent Welch Index: Makefile.in ================================================================== --- Makefile.in +++ Makefile.in @@ -7,10 +7,11 @@ LIBS = @LIBS@ PACKAGE_VERSION = @PACKAGE_VERSION@ prefix = @prefix@ exec_prefix = @exec_prefix@ libdir = @libdir@ +genericdir = @srcdir@/generic TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ PACKAGE_INSTALL_DIR = $(TCL_PACKAGE_PATH)/tcltls$(PACKAGE_VERSION) INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_DATA = @INSTALL_DATA@ @@ -31,21 +32,21 @@ static-@EXTENSION_TARGET@: tls.o tlsBIO.o tlsIO.o tlsX509.o Makefile $(AR) rcu static-@EXTENSION_TARGET@ tls.o tlsBIO.o tlsIO.o tlsX509.o -$(RANLIB) static-@EXTENSION_TARGET@ # Dependencies for all our targets -tls.o: @srcdir@/tls.c @srcdir@/tlsInt.h @srcdir@/tclOpts.h tls.tcl.h dh_params.h Makefile - $(CC) $(CPPFLAGS) $(CFLAGS) -o tls.o -c @srcdir@/tls.c - -tlsBIO.o: @srcdir@/tlsBIO.c @srcdir@/tlsInt.h Makefile - $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsBIO.o -c @srcdir@/tlsBIO.c - -tlsIO.o: @srcdir@/tlsIO.c @srcdir@/tlsInt.h Makefile - $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsIO.o -c @srcdir@/tlsIO.c - -tlsX509.o: @srcdir@/tlsX509.c @srcdir@/tlsInt.h Makefile - $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsX509.o -c @srcdir@/tlsX509.c +tls.o: $(genericdir)/tls.c $(genericdir)/tlsInt.h $(genericdir)/tclOpts.h tls.tcl.h dh_params.h Makefile + $(CC) $(CPPFLAGS) $(CFLAGS) -o tls.o -c $(genericdir)/tls.c + +tlsBIO.o: $(genericdir)/tlsBIO.c $(genericdir)/tlsInt.h Makefile + $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsBIO.o -c $(genericdir)/tlsBIO.c + +tlsIO.o: $(genericdir)/tlsIO.c $(genericdir)/tlsInt.h Makefile + $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsIO.o -c $(genericdir)/tlsIO.c + +tlsX509.o: $(genericdir)/tlsX509.c $(genericdir)/tlsInt.h Makefile + $(CC) $(CPPFLAGS) $(CFLAGS) -o tlsX509.o -c $(genericdir)/tlsX509.c # Create a C-source-ified version of the script resources # for TclTLS so that we only need a single file to enable # this extension tls.tcl.h: @srcdir@/tls.tcl Makefile Index: README.txt ================================================================== --- README.txt +++ README.txt @@ -1,5 +1,12 @@ +TclTLS 1.7.22 +========== + +Release Date: Mon Oct 12 15:40:16 CDT 2020 + +https://tcltls.rkeene.org/ + Original TLS Copyright (C) 1997-2000 Matt Newman TLS 1.4.1 Copyright (C) 2000 Ajuba Solutions TLS 1.6 Copyright (C) 2008 ActiveState Software Inc. TLS 1.7 Copyright (C) 2016 Matt Newman, Ajuba Solutions, ActiveState Software Inc, Roy Keene Index: aclocal/shobj.m4 ================================================================== --- aclocal/shobj.m4 +++ aclocal/shobj.m4 @@ -226,11 +226,11 @@ AC_DEFUN([SHOBJ_DO_STATIC_LINK_LIB], [ ifelse($3, [], [ define([VAR_TO_UPDATE], [LIBS]) ], [ define([VAR_TO_UPDATE], [$3]) - ]) + ]) AC_MSG_CHECKING([for how to statically link to $1]) trylink_ADD_LDFLAGS='' Index: build/makearch.info ================================================================== --- build/makearch.info +++ build/makearch.info @@ -1,9 +1,9 @@ # This is the name of the utility, it will be prefixed to the tarball name UTIL="tcltls" -# This is the name of output files that should exist after configure +# This is the name of output files that should exist after configure # procedures. BINS="tcltls.so" # This lists the name of files that are required to exist REQS="" Index: configure.ac ================================================================== --- configure.ac +++ configure.ac @@ -1,7 +1,7 @@ dnl Define ourselves -AC_INIT(tcltls, 1.8.0) +AC_INIT([tcltls],[1.8.0]) dnl Checks for programs. AC_PROG_CC AC_PROG_MAKE_SET AC_PROG_INSTALL @@ -251,6 +251,7 @@ WEAKENSYMS=':' REMOVESYMS=':' fi dnl Produce output -AC_OUTPUT(Makefile pkgIndex.tcl tcltls.syms) +AC_CONFIG_FILES([Makefile pkgIndex.tcl tcltls.syms]) +AC_OUTPUT ADDED generic/tclOpts.h Index: generic/tclOpts.h ================================================================== --- /dev/null +++ generic/tclOpts.h @@ -0,0 +1,58 @@ +/* + * Copyright (C) 1997-2000 Matt Newman + * + * Stylized option processing - requires consitent + * external vars: opt, idx, objc, objv + */ +#ifndef _TCL_OPTS_H +#define _TCL_OPTS_H + +#define OPT_PROLOG(option) \ + if (strcmp(opt, (option)) == 0) { \ + if (++idx >= objc) { \ + Tcl_AppendResult(interp, \ + "no argument given for ", \ + (option), " option", \ + (char *) NULL); \ + return TCL_ERROR; \ + } +#define OPT_POSTLOG() \ + continue; \ + } +#define OPTOBJ(option, var) \ + OPT_PROLOG(option) \ + var = objv[idx]; \ + OPT_POSTLOG() + +#define OPTSTR(option, var) \ + OPT_PROLOG(option) \ + var = Tcl_GetString(objv[idx]);\ + OPT_POSTLOG() + +#define OPTINT(option, var) \ + OPT_PROLOG(option) \ + if (Tcl_GetIntFromObj(interp, objv[idx], \ + &(var)) != TCL_OK) { \ + return TCL_ERROR; \ + } \ + OPT_POSTLOG() + +#define OPTBOOL(option, var) \ + OPT_PROLOG(option) \ + if (Tcl_GetBooleanFromObj(interp, objv[idx],\ + &(var)) != TCL_OK) { \ + return TCL_ERROR; \ + } \ + OPT_POSTLOG() + +#define OPTBYTE(option, var, lvar) \ + OPT_PROLOG(option) \ + var = Tcl_GetByteArrayFromObj(objv[idx], &(lvar));\ + OPT_POSTLOG() + +#define OPTBAD(type, list) \ + Tcl_AppendResult(interp, "bad ", (type), \ + " \"", opt, "\": must be ", \ + (list), (char *) NULL) + +#endif /* _TCL_OPTS_H */ ADDED generic/tls.c Index: generic/tls.c ================================================================== --- /dev/null +++ generic/tls.c @@ -0,0 +1,1947 @@ +/* + * Copyright (C) 1997-1999 Matt Newman + * some modifications: + * Copyright (C) 2000 Ajuba Solutions + * Copyright (C) 2002 ActiveState Corporation + * Copyright (C) 2004 Starfish Systems + * + * TLS (aka SSL) Channel - can be layered on any bi-directional + * Tcl_Channel (Note: Requires Trf Core Patch) + * + * This was built (almost) from scratch based upon observation of + * OpenSSL 0.9.2B + * + * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for + * providing the Tcl_ReplaceChannel mechanism and working closely with me + * to enhance it to support full fileevent semantics. + * + * Also work done by the follow people provided the impetus to do this "right": + * tclSSL (Colin McCormack, Shared Technology) + * SSLtcl (Peter Antman) + * + */ + +#include "tlsInt.h" +#include "tclOpts.h" +#include + +/* + * External functions + */ + +/* + * Forward declarations + */ + +#define F2N( key, dsp) \ + (((key) == NULL) ? (char *) NULL : \ + Tcl_TranslateFileName(interp, (key), (dsp))) +#define REASON() ERR_reason_error_string(ERR_get_error()) + +static void InfoCallback(const SSL *ssl, int where, int ret); + +static Tcl_ObjCmdProc CiphersObjCmd; +static Tcl_ObjCmdProc HandshakeObjCmd; +static Tcl_ObjCmdProc ImportObjCmd; +static Tcl_ObjCmdProc StatusObjCmd; +static Tcl_ObjCmdProc VersionObjCmd; +static Tcl_ObjCmdProc MiscObjCmd; +static Tcl_ObjCmdProc UnimportObjCmd; + +static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key, + char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1, + int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile, + char *ciphers, char *DHparams); + +static int TlsLibInit(int uninitialize); + +#define TLS_PROTO_SSL2 0x01 +#define TLS_PROTO_SSL3 0x02 +#define TLS_PROTO_TLS1 0x04 +#define TLS_PROTO_TLS1_1 0x08 +#define TLS_PROTO_TLS1_2 0x10 +#define TLS_PROTO_TLS1_3 0x20 +#define ENABLED(flag, mask) (((flag) & (mask)) == (mask)) + +/* + * Static data structures + */ + +#ifndef OPENSSL_NO_DH +#include "dh_params.h" +#endif + +/* + * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2 + * libraries instead of the current OpenSSL libraries. + */ + +#ifdef BSAFE +#define PRE_OPENSSL_0_9_4 1 +#endif + +/* + * Pre OpenSSL 0.9.4 Compat + */ + +#ifndef STACK_OF +#define STACK_OF(x) STACK +#define sk_SSL_CIPHER_num(sk) sk_num((sk)) +#define sk_SSL_CIPHER_value( sk, index) (SSL_CIPHER*)sk_value((sk), (index)) +#endif + +/* + * Thread-Safe TLS Code + */ + +#ifdef TCL_THREADS +#define OPENSSL_THREAD_DEFINES +#include + +#ifdef OPENSSL_THREADS +#include + +/* + * Threaded operation requires locking callbacks + * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL. + */ + +static Tcl_Mutex *locks = NULL; +static int locksCount = 0; +static Tcl_Mutex init_mx; + +void CryptoThreadLockCallback(int mode, int n, const char *file, int line) { + + if (mode & CRYPTO_LOCK) { + /* This debugging is turned off by default -- it's too noisy. */ + /* dprintf("Called to lock (n=%i of %i)", n, locksCount); */ + Tcl_MutexLock(&locks[n]); + } else { + /* dprintf("Called to unlock (n=%i of %i)", n, locksCount); */ + Tcl_MutexUnlock(&locks[n]); + } + + /* dprintf("Returning"); */ + + return; + file = file; + line = line; +} + +unsigned long CryptoThreadIdCallback(void) { + unsigned long ret; + + dprintf("Called"); + + ret = (unsigned long) Tcl_GetCurrentThread(); + + dprintf("Returning %lu", ret); + + return(ret); +} +#endif /* OPENSSL_THREADS */ +#endif /* TCL_THREADS */ + + +/* + *------------------------------------------------------------------- + * + * InfoCallback -- + * + * monitors SSL connection process + * + * Results: + * None + * + * Side effects: + * Calls callback (if defined) + *------------------------------------------------------------------- + */ +static void +InfoCallback(const SSL *ssl, int where, int ret) +{ + State *statePtr = (State*)SSL_get_app_data((SSL *)ssl); + Tcl_Obj *cmdPtr; + const char *major, *minor; + + dprintf("Called"); + + if (statePtr->callback == (Tcl_Obj*)NULL) + return; + + cmdPtr = Tcl_DuplicateObj(statePtr->callback); + +#if 0 + if (where & SSL_CB_ALERT) { + sev = SSL_alert_type_string_long(ret); + if (strcmp( sev, "fatal")==0) { /* Map to error */ + Tls_Error(statePtr, SSL_ERROR(ssl, 0)); + return; + } + } +#endif + if (where & SSL_CB_HANDSHAKE_START) { + major = "handshake"; + minor = "start"; + } else if (where & SSL_CB_HANDSHAKE_DONE) { + major = "handshake"; + minor = "done"; + } else { + if (where & SSL_CB_ALERT) major = "alert"; + else if (where & SSL_ST_CONNECT) major = "connect"; + else if (where & SSL_ST_ACCEPT) major = "accept"; + else major = "unknown"; + + if (where & SSL_CB_READ) minor = "read"; + else if (where & SSL_CB_WRITE) minor = "write"; + else if (where & SSL_CB_LOOP) minor = "loop"; + else if (where & SSL_CB_EXIT) minor = "exit"; + else minor = "unknown"; + } + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( "info", -1)); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( major, -1) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( minor, -1) ); + + if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) { + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); + } else if (where & SSL_CB_ALERT) { + const char *cp = (char *) SSL_alert_desc_string_long(ret); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( cp, -1) ); + } else { + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); + } + Tcl_Preserve( (ClientData) statePtr->interp); + Tcl_Preserve( (ClientData) statePtr); + + Tcl_IncrRefCount( cmdPtr); + (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount( cmdPtr); + + Tcl_Release( (ClientData) statePtr); + Tcl_Release( (ClientData) statePtr->interp); + +} + +/* + *------------------------------------------------------------------- + * + * VerifyCallback -- + * + * Monitors SSL certificate validation process. + * This is called whenever a certificate is inspected + * or decided invalid. + * + * Results: + * A callback bound to the socket may return one of: + * 0 - the certificate is deemed invalid + * 1 - the certificate is deemed valid + * empty string - no change to certificate validation + * + * Side effects: + * The err field of the currently operative State is set + * to a string describing the SSL negotiation failure reason + *------------------------------------------------------------------- + */ +static int +VerifyCallback(int ok, X509_STORE_CTX *ctx) +{ + Tcl_Obj *cmdPtr, *result; + char *errStr, *string; + Tcl_Size length; + SSL *ssl = (SSL*)X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx()); + X509 *cert = X509_STORE_CTX_get_current_cert(ctx); + State *statePtr = (State*)SSL_get_app_data(ssl); + int depth = X509_STORE_CTX_get_error_depth(ctx); + int err = X509_STORE_CTX_get_error(ctx); + + dprintf("Verify: %d", ok); + + if (!ok) { + errStr = (char*)X509_verify_cert_error_string(err); + } else { + errStr = (char *)0; + } + + if (statePtr->callback == (Tcl_Obj*)NULL) { + if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) { + return ok; + } else { + return 1; + } + } + cmdPtr = Tcl_DuplicateObj(statePtr->callback); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( "verify", -1)); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewIntObj( depth) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tls_NewX509Obj( statePtr->interp, cert) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewIntObj( ok) ); + + Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, + Tcl_NewStringObj( errStr ? errStr : "", -1) ); + + Tcl_Preserve( (ClientData) statePtr->interp); + Tcl_Preserve( (ClientData) statePtr); + + statePtr->flags |= TLS_TCL_CALLBACK; + + Tcl_IncrRefCount( cmdPtr); + if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { + /* It got an error - reject the certificate. */ + Tcl_BackgroundError( statePtr->interp); + ok = 0; + } else { + result = Tcl_GetObjResult(statePtr->interp); + string = Tcl_GetStringFromObj(result, &length); + /* An empty result leaves verification unchanged. */ + if (string != NULL && length > 0) { + if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) { + Tcl_BackgroundError(statePtr->interp); + ok = 0; + } + } + } + Tcl_DecrRefCount( cmdPtr); + + statePtr->flags &= ~(TLS_TCL_CALLBACK); + + Tcl_Release( (ClientData) statePtr); + Tcl_Release( (ClientData) statePtr->interp); + + return(ok); /* By default, leave verification unchanged. */ +} + +/* + *------------------------------------------------------------------- + * + * Tls_Error -- + * + * Calls callback with $fd and $msg - so the callback can decide + * what to do with errors. + * + * Side effects: + * The err field of the currently operative State is set + * to a string describing the SSL negotiation failure reason + *------------------------------------------------------------------- + */ +void +Tls_Error(State *statePtr, char *msg) +{ + Tcl_Obj *cmdPtr; + + dprintf("Called"); + + if (msg && *msg) { + Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL); + } else { + msg = Tcl_GetString(Tcl_GetObjResult(statePtr->interp)); + } + statePtr->err = msg; + + if (statePtr->callback == (Tcl_Obj*)NULL) { + char buf[BUFSIZ]; + sprintf(buf, "SSL channel \"%s\": error: %s", + Tcl_GetChannelName(statePtr->self), msg); + Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE); + Tcl_BackgroundError( statePtr->interp); + return; + } + cmdPtr = Tcl_DuplicateObj(statePtr->callback); + + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj("error", -1)); + + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1)); + + Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, + Tcl_NewStringObj(msg, -1)); + + Tcl_Preserve((ClientData) statePtr->interp); + Tcl_Preserve((ClientData) statePtr); + + Tcl_IncrRefCount(cmdPtr); + if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { + Tcl_BackgroundError(statePtr->interp); + } + Tcl_DecrRefCount(cmdPtr); + + Tcl_Release((ClientData) statePtr); + Tcl_Release((ClientData) statePtr->interp); +} + +/* + *------------------------------------------------------------------- + * + * PasswordCallback -- + * + * Called when a password is needed to unpack RSA and PEM keys. + * Evals any bound password script and returns the result as + * the password string. + *------------------------------------------------------------------- + */ +#ifdef PRE_OPENSSL_0_9_4 +/* + * No way to handle user-data therefore no way without a global + * variable to access the Tcl interpreter. +*/ +static int +PasswordCallback(char *buf, int size, int verify) +{ + return -1; + buf = buf; + size = size; + verify = verify; +} +#else +static int +PasswordCallback(char *buf, int size, int verify, void *udata) +{ + State *statePtr = (State *) udata; + Tcl_Interp *interp = statePtr->interp; + Tcl_Obj *cmdPtr; + int result; + + dprintf("Called"); + + if (statePtr->password == NULL) { + if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) + == TCL_OK) { + char *ret = (char *) Tcl_GetStringResult(interp); + strncpy(buf, ret, (size_t) size); + return (int)strlen(ret); + } else { + return -1; + } + } + + cmdPtr = Tcl_DuplicateObj(statePtr->password); + + Tcl_Preserve((ClientData) statePtr->interp); + Tcl_Preserve((ClientData) statePtr); + + Tcl_IncrRefCount(cmdPtr); + result = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + if (result != TCL_OK) { + Tcl_BackgroundError(statePtr->interp); + } + Tcl_DecrRefCount(cmdPtr); + + Tcl_Release((ClientData) statePtr); + Tcl_Release((ClientData) statePtr->interp); + + if (result == TCL_OK) { + char *ret = (char *) Tcl_GetStringResult(interp); + strncpy(buf, ret, (size_t) size); + return (int)strlen(ret); + } else { + return -1; + } + verify = verify; +} +#endif + +/* + *------------------------------------------------------------------- + * + * CiphersObjCmd -- list available ciphers + * + * This procedure is invoked to process the "tls::ciphers" command + * to list available ciphers, based upon protocol selected. + * + * Results: + * A standard Tcl result list. + * + * Side effects: + * constructs and destroys SSL context (CTX) + * + *------------------------------------------------------------------- + */ +static int +CiphersObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *protocols[] = { + "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL + }; + enum protocol { + TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE + }; + Tcl_Obj *objPtr; + SSL_CTX *ctx = NULL; + SSL *ssl = NULL; + STACK_OF(SSL_CIPHER) *sk; + char *cp, buf[BUFSIZ]; + int index, verbose = 0; + + dprintf("Called"); + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (objc > 2 && Tcl_GetBooleanFromObj( interp, objv[2], + &verbose) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum protocol)index) { + case TLS_SSL2: +#if defined(NO_SSL2) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(SSLv2_method()); break; +#endif + case TLS_SSL3: +#if defined(NO_SSL3) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(SSLv3_method()); break; +#endif + case TLS_TLS1: +#if defined(NO_TLS1) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(TLSv1_method()); break; +#endif + case TLS_TLS1_1: +#if defined(NO_TLS1_1) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(TLSv1_1_method()); break; +#endif + case TLS_TLS1_2: +#if defined(NO_TLS1_2) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(TLSv1_2_method()); break; +#endif + case TLS_TLS1_3: +#if defined(NO_TLS1_3) + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return TCL_ERROR; +#else + ctx = SSL_CTX_new(TLS_method()); break; + SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION); + SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION); +#endif + default: + break; + } + if (ctx == NULL) { + Tcl_AppendResult(interp, REASON(), (char *) NULL); + return TCL_ERROR; + } + ssl = SSL_new(ctx); + if (ssl == NULL) { + Tcl_AppendResult(interp, REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return TCL_ERROR; + } + objPtr = Tcl_NewListObj( 0, NULL); + + if (!verbose) { + for (index = 0; ; index++) { + cp = (char*)SSL_get_cipher_list( ssl, index); + if (cp == NULL) break; + Tcl_ListObjAppendElement( interp, objPtr, + Tcl_NewStringObj( cp, -1) ); + } + } else { + sk = SSL_get_ciphers(ssl); + + for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) { + size_t i; + SSL_CIPHER_description( sk_SSL_CIPHER_value( sk, index), + buf, sizeof(buf)); + for (i = strlen(buf) - 1; i ; i--) { + if (buf[i] == ' ' || buf[i] == '\n' || + buf[i] == '\r' || buf[i] == '\t') { + buf[i] = '\0'; + } else { + break; + } + } + Tcl_ListObjAppendElement( interp, objPtr, + Tcl_NewStringObj( buf, -1) ); + } + } + SSL_free(ssl); + SSL_CTX_free(ctx); + + Tcl_SetObjResult( interp, objPtr); + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * + * HandshakeObjCmd -- + * + * This command is used to verify whether the handshake is complete + * or not. + * + * Results: + * A standard Tcl result. 1 means handshake complete, 0 means pending. + * + * Side effects: + * May force SSL negotiation to take place. + * + *------------------------------------------------------------------- + */ + +static int HandshakeObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + State *statePtr; /* client state for ssl socket */ + const char *errStr = NULL; + int ret = 1; + int err = 0; + + dprintf("Called"); + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel"); + return(TCL_ERROR); + } + + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + if (chan == (Tcl_Channel) NULL) { + return(TCL_ERROR); + } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", (char *)NULL); + return(TCL_ERROR); + } + statePtr = (State *)Tcl_GetChannelInstanceData(chan); + + dprintf("Calling Tls_WaitForConnect"); + ret = Tls_WaitForConnect(statePtr, &err, 1); + dprintf("Tls_WaitForConnect returned: %i", ret); + + if ( + ret < 0 && \ + ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN) + ) { + dprintf("Async set and err = EAGAIN"); + ret = 0; + } else if (ret < 0) { + errStr = statePtr->err; + Tcl_ResetResult(interp); + Tcl_SetErrno(err); + + if (!errStr || *errStr == 0) { + errStr = Tcl_PosixError(interp); + } + + Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL); + dprintf("Returning TCL_ERROR with handshake failed: %s", errStr); + return(TCL_ERROR); + } else { + if (err != 0) { + dprintf("Got an error with a completed handshake: err = %i", err); + } + + ret = 1; + } + + dprintf("Returning TCL_OK with data \"%i\"", ret); + Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); + return(TCL_OK); +} + +/* + *------------------------------------------------------------------- + * + * ImportObjCmd -- + * + * This procedure is invoked to process the "ssl" command + * + * The ssl command pushes SSL over a (newly connected) tcp socket + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *------------------------------------------------------------------- + */ + +static int +ImportObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + State *statePtr; /* client state for ssl socket */ + SSL_CTX *ctx = NULL; + Tcl_Obj *script = NULL; + Tcl_Obj *password = NULL; + Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar; + int idx; + Tcl_Size len; + int flags = TLS_TCL_INIT; + int server = 0; /* is connection incoming or outgoing? */ + char *keyfile = NULL; + char *certfile = NULL; + unsigned char *key = NULL; + Tcl_Size key_len = 0; + unsigned char *cert = NULL; + Tcl_Size cert_len = 0; + char *ciphers = NULL; + char *CAfile = NULL; + char *CAdir = NULL; + char *DHparams = NULL; + char *model = NULL; +#ifndef OPENSSL_NO_TLSEXT + char *servername = NULL; /* hostname for Server Name Indication */ +#endif + int ssl2 = 0, ssl3 = 0; + int tls1 = 1, tls1_1 = 1, tls1_2 = 1, tls1_3 = 1; + int proto = 0; + int verify = 0, require = 0, request = 1; + + dprintf("Called"); + +#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL3) && !defined(NO_SSL2) + ssl2 = 1; +#endif +#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL2) && !defined(NO_SSL3) + ssl3 = 1; +#endif +#if defined(NO_TLS1) + tls1 = 0; +#endif +#if defined(NO_TLS1_1) + tls1_1 = 0; +#endif +#if defined(NO_TLS1_2) + tls1_2 = 0; +#endif +#if defined(NO_TLS1_3) + tls1_3 = 0; +#endif + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + + for (idx = 2; idx < objc; idx++) { + char *opt = Tcl_GetString(objv[idx]); + + if (opt[0] != '-') + break; + + OPTSTR( "-cadir", CAdir); + OPTSTR( "-cafile", CAfile); + OPTSTR( "-certfile", certfile); + OPTSTR( "-cipher", ciphers); + OPTOBJ( "-command", script); + OPTSTR( "-dhparams", DHparams); + OPTSTR( "-keyfile", keyfile); + OPTSTR( "-model", model); + OPTOBJ( "-password", password); + OPTBOOL( "-require", require); + OPTBOOL( "-request", request); + OPTBOOL( "-server", server); +#ifndef OPENSSL_NO_TLSEXT + OPTSTR( "-servername", servername); +#endif + + OPTBOOL( "-ssl2", ssl2); + OPTBOOL( "-ssl3", ssl3); + OPTBOOL( "-tls1", tls1); + OPTBOOL( "-tls1.1", tls1_1); + OPTBOOL( "-tls1.2", tls1_2); + OPTBOOL( "-tls1.3", tls1_3) + OPTBYTE("-cert", cert, cert_len); + OPTBYTE("-key", key, key_len); + + OPTBAD( "option", "-cadir, -cafile, -cert, -certfile, -cipher, -command, -dhparams, -key, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or tls1.3"); + + return TCL_ERROR; + } + if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; + if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; + if (verify == 0) verify = SSL_VERIFY_NONE; + + proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); + proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); + proto |= (tls1 ? TLS_PROTO_TLS1 : 0); + proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0); + proto |= (tls1_2 ? TLS_PROTO_TLS1_2 : 0); + proto |= (tls1_3 ? TLS_PROTO_TLS1_3 : 0); + + /* reset to NULL if blank string provided */ + if (cert && !*cert) cert = NULL; + if (key && !*key) key = NULL; + if (certfile && !*certfile) certfile = NULL; + if (keyfile && !*keyfile) keyfile = NULL; + if (ciphers && !*ciphers) ciphers = NULL; + if (CAfile && !*CAfile) CAfile = NULL; + if (CAdir && !*CAdir) CAdir = NULL; + if (DHparams && !*DHparams) DHparams = NULL; + + /* new SSL state */ + statePtr = (State *) ckalloc((unsigned) sizeof(State)); + memset(statePtr, 0, sizeof(State)); + + statePtr->flags = flags; + statePtr->interp = interp; + statePtr->vflags = verify; + statePtr->err = ""; + + /* allocate script */ + if (script) { + (void) Tcl_GetStringFromObj(script, &len); + if (len) { + statePtr->callback = script; + Tcl_IncrRefCount(statePtr->callback); + } + } + + /* allocate password */ + if (password) { + (void) Tcl_GetStringFromObj(password, &len); + if (len) { + statePtr->password = password; + Tcl_IncrRefCount(statePtr->password); + } + } + + if (model != NULL) { + int mode; + /* Get the "model" context */ + chan = Tcl_GetChannel(interp, model, &mode); + if (chan == (Tcl_Channel) NULL) { + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", + Tcl_GetChannelName(chan), "\": not a TLS channel", (char *)NULL); + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx; + } else { + if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, + cert, key_len, cert_len, CAdir, CAfile, ciphers, + DHparams)) == (SSL_CTX*)0) { + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + } + + statePtr->ctx = ctx; + + /* + * We need to make sure that the channel works in binary (for the + * encryption not to get goofed up). + * We only want to adjust the buffering in pre-v2 channels, where + * each channel in the stack maintained its own buffers. + */ + Tcl_DStringInit(&upperChannelTranslation); + Tcl_DStringInit(&upperChannelBlocking); + Tcl_DStringInit(&upperChannelEOFChar); + Tcl_DStringInit(&upperChannelEncoding); + Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar); + Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding); + Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation); + Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking); + Tcl_SetChannelOption(interp, chan, "-translation", "binary"); + Tcl_SetChannelOption(interp, chan, "-blocking", "true"); + dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan)); + statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), statePtr, (TCL_READABLE | TCL_WRITABLE), chan); + dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self)); + if (statePtr->self == (Tcl_Channel) NULL) { + /* + * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. + */ + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + + Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation)); + Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding)); + Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar)); + Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking)); + + /* + * SSL Initialization + */ + + statePtr->ssl = SSL_new(statePtr->ctx); + if (!statePtr->ssl) { + /* SSL library error */ + Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), + (char *) NULL); + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + +#ifndef OPENSSL_NO_TLSEXT + if (servername) { + if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) { + Tcl_AppendResult(interp, "setting TLS host name extension failed", + (char *) NULL); + Tls_Free((void *)statePtr); + return TCL_ERROR; + } + } +#endif + + /* + * SSL Callbacks + */ + + SSL_set_app_data(statePtr->ssl, (void *)statePtr); /* point back to us */ + + SSL_set_verify(statePtr->ssl, verify, VerifyCallback); + + SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); + + /* Create Tcl_Channel BIO Handler */ + statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE); + statePtr->bio = BIO_new(BIO_f_ssl()); + + if (server) { + statePtr->flags |= TLS_TCL_SERVER; + SSL_set_accept_state(statePtr->ssl); + } else { + SSL_set_connect_state(statePtr->ssl); + } + SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); + BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); + + /* + * End of SSL Init + */ + dprintf("Returning %s", Tcl_GetChannelName(statePtr->self)); + Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), + TCL_VOLATILE); + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * + * UnimportObjCmd -- + * + * This procedure is invoked to remove the topmost channel filter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *------------------------------------------------------------------- + */ + +static int +UnimportObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + + dprintf("Called"); + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), + "\": not a TLS channel", (char *)NULL); + return TCL_ERROR; + } + + if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * + * CTX_Init -- construct a SSL_CTX instance + * + * Results: + * A valid SSL_CTX instance or NULL. + * + * Side effects: + * constructs SSL context (CTX) + * + *------------------------------------------------------------------- + */ + +static SSL_CTX * +CTX_Init( + State *statePtr, + TCL_UNUSED(int) /* isServer */, + int proto, + char *keyfile, + char *certfile, + unsigned char *key, + unsigned char *cert, + int key_len, + int cert_len, + char *CAdir, + char *CAfile, + char *ciphers, + char *DHparams) +{ + Tcl_Interp *interp = statePtr->interp; + SSL_CTX *ctx = NULL; + Tcl_DString ds; + Tcl_DString ds1; + int off = 0; + int load_private_key; + const SSL_METHOD *method; + + dprintf("Called"); + + if (!proto) { + Tcl_AppendResult(interp, "no valid protocol selected", (char *)NULL); + return (SSL_CTX *)0; + } + + /* create SSL context */ +#if defined(NO_SSL2) + if (ENABLED(proto, TLS_PROTO_SSL2)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif +#if defined(NO_SSL3) + if (ENABLED(proto, TLS_PROTO_SSL3)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif +#if defined(NO_TLS1) + if (ENABLED(proto, TLS_PROTO_TLS1)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif +#if defined(NO_TLS1_1) + if (ENABLED(proto, TLS_PROTO_TLS1_1)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif +#if defined(NO_TLS1_2) + if (ENABLED(proto, TLS_PROTO_TLS1_2)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif +#if defined(NO_TLS1_3) + if (ENABLED(proto, TLS_PROTO_TLS1_3)) { + Tcl_AppendResult(interp, "protocol not supported", (char *)NULL); + return (SSL_CTX *)0; + } +#endif + + switch (proto) { +#if !defined(NO_SSL2) + case TLS_PROTO_SSL2: + method = SSLv2_method (); + break; +#endif +#if !defined(NO_SSL3) + case TLS_PROTO_SSL3: + method = SSLv3_method (); + break; +#endif +#if !defined(NO_TLS1) + case TLS_PROTO_TLS1: + method = TLSv1_method (); + break; +#endif +#if !defined(NO_TLS1_1) + case TLS_PROTO_TLS1_1: + method = TLSv1_1_method (); + break; +#endif +#if !defined(NO_TLS1_2) + case TLS_PROTO_TLS1_2: + method = TLSv1_2_method (); + break; +#endif +#if !defined(NO_TLS1_3) + case TLS_PROTO_TLS1_3: + /* + * The version range is constrained below, + * after the context is created. Use the + * generic method here. + */ + method = TLS_method (); + break; +#endif + default: +#ifdef HAVE_TLS_METHOD + method = TLS_method (); +#else + method = SSLv23_method (); +#endif +#if !defined(NO_SSL2) + off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2); +#endif +#if !defined(NO_SSL3) + off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3); +#endif +#if !defined(NO_TLS1) + off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1); +#endif +#if !defined(NO_TLS1_1) + off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1); +#endif +#if !defined(NO_TLS1_2) + off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2); +#endif +#if !defined(NO_TLS1_3) + off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3); +#endif + break; + } + + ctx = SSL_CTX_new (method); + + if (!ctx) { + return(NULL); + } + +#if !defined(NO_TLS1_3) + if (proto == TLS_PROTO_TLS1_3) { + SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION); + SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION); + } +#endif + + SSL_CTX_set_app_data( ctx, (void*)interp); /* remember the interpreter */ + SSL_CTX_set_options( ctx, SSL_OP_ALL); /* all SSL bug workarounds */ + SSL_CTX_set_options( ctx, off); /* all SSL bug workarounds */ + SSL_CTX_sess_set_cache_size( ctx, 128); + + if (ciphers != NULL) + SSL_CTX_set_cipher_list(ctx, ciphers); + + /* set some callbacks */ + SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); + +#ifndef BSAFE + SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr); +#endif + + /* read a Diffie-Hellman parameters file, or use the built-in one */ +#ifdef OPENSSL_NO_DH + if (DHparams != NULL) { + Tcl_AppendResult(interp, + "DH parameter support not available", (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } +#else + { + DH* dh; + if (DHparams != NULL) { + BIO *bio; + Tcl_DStringInit(&ds); + bio = BIO_new_file(F2N(DHparams, &ds), "r"); + if (!bio) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "Could not find DH parameters file", (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + + dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL); + BIO_free(bio); + Tcl_DStringFree(&ds); + if (!dh) { + Tcl_AppendResult(interp, + "Could not read DH parameters from file", (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + } else { + dh = get_dhParams(); + } + SSL_CTX_set_tmp_dh(ctx, dh); + DH_free(dh); + } +#endif + + /* set our certificate */ + load_private_key = 0; + if (certfile != NULL) { + load_private_key = 1; + + Tcl_DStringInit(&ds); + + if (SSL_CTX_use_certificate_file(ctx, F2N( certfile, &ds), + SSL_FILETYPE_PEM) <= 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "unable to set certificate file ", certfile, ": ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + } else if (cert != NULL) { + load_private_key = 1; + if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "unable to set certificate: ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + } else { + certfile = (char*)X509_get_default_cert_file(); + + if (SSL_CTX_use_certificate_file(ctx, certfile, + SSL_FILETYPE_PEM) <= 0) { +#if 0 + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "unable to use default certificate file ", certfile, ": ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; +#endif + } + } + + /* set our private key */ + if (load_private_key) { + if (keyfile == NULL && key == NULL) { + keyfile = certfile; + } + + if (keyfile != NULL) { + /* get the private key associated with this certificate */ + if (keyfile == NULL) { + keyfile = certfile; + } + + if (SSL_CTX_use_PrivateKey_file(ctx, F2N( keyfile, &ds), SSL_FILETYPE_PEM) <= 0) { + Tcl_DStringFree(&ds); + /* flush the passphrase which might be left in the result */ + Tcl_SetResult(interp, NULL, TCL_STATIC); + Tcl_AppendResult(interp, + "unable to set public key file ", keyfile, " ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + + Tcl_DStringFree(&ds); + } else if (key != NULL) { + if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) { + Tcl_DStringFree(&ds); + /* flush the passphrase which might be left in the result */ + Tcl_SetResult(interp, NULL, TCL_STATIC); + Tcl_AppendResult(interp, + "unable to set public key: ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + } + /* Now we know that a key and cert have been set against + * the SSL context */ + if (!SSL_CTX_check_private_key(ctx)) { + Tcl_AppendResult(interp, + "private key does not match the certificate public key", + (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; + } + } + + /* Set verification CAs */ + Tcl_DStringInit(&ds); + Tcl_DStringInit(&ds1); + if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) || + !SSL_CTX_set_default_verify_paths(ctx)) { +#if 0 + Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds1); + /* Don't currently care if this fails */ + Tcl_AppendResult(interp, "SSL default verify paths: ", + REASON(), (char *) NULL); + SSL_CTX_free(ctx); + return (SSL_CTX *)0; +#endif + } + + /* https://sourceforge.net/p/tls/bugs/57/ */ + /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */ + if ( CAfile != NULL ) { + STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file( F2N(CAfile, &ds) ); + if ( certNames != NULL ) { + SSL_CTX_set_client_CA_list(ctx, certNames ); + } + } + + Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds1); + return ctx; +} + +/* + *------------------------------------------------------------------- + * + * StatusObjCmd -- return certificate for connected peer. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +StatusObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + State *statePtr; + X509 *peer; + Tcl_Obj *objPtr; + Tcl_Channel chan; + char *channelName, *ciphers; + int mode; + + dprintf("Called"); + + switch (objc) { + case 2: + channelName = Tcl_GetString(objv[1]); + break; + + case 3: + if (!strcmp (Tcl_GetString (objv[1]), "-local")) { + channelName = Tcl_GetString(objv[2]); + break; + } + /* fallthrough */ + default: + Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, channelName, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), + "\": not a TLS channel", (char *)NULL); + return TCL_ERROR; + } + statePtr = (State *) Tcl_GetChannelInstanceData(chan); + if (objc == 2) { + peer = SSL_get_peer_certificate(statePtr->ssl); + } else { + peer = SSL_get_certificate(statePtr->ssl); + } + if (peer) { + objPtr = Tls_NewX509Obj(interp, peer); + if (objc == 2) { X509_free(peer); } + } else { + objPtr = Tcl_NewListObj(0, NULL); + } + + Tcl_ListObjAppendElement (interp, objPtr, + Tcl_NewStringObj ("sbits", -1)); + Tcl_ListObjAppendElement (interp, objPtr, + Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL))); + + ciphers = (char*)SSL_get_cipher(statePtr->ssl); + if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) { + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("cipher", -1)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); + } + + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj("version", -1)); + Tcl_ListObjAppendElement(interp, objPtr, + Tcl_NewStringObj(SSL_get_version(statePtr->ssl), -1)); + + Tcl_SetObjResult( interp, objPtr); + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * + * VersionObjCmd -- return version string from OpenSSL. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +VersionObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + TCL_UNUSED(int) /* objc */, + TCL_UNUSED(Tcl_Obj *const *) /* objv */) +{ + Tcl_Obj *objPtr; + + dprintf("Called"); + + objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); + + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * + * MiscObjCmd -- misc commands + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +MiscObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *commands [] = { "req", NULL }; + enum command { C_REQ, C_DUMMY }; + int cmd; + + dprintf("Called"); + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], commands, + "command", 0,&cmd) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum command) cmd) { + case C_REQ: { + EVP_PKEY *pkey=NULL; + X509 *cert=NULL; + X509_NAME *name=NULL; + Tcl_Obj **listv; + Tcl_Size listc,i; + + BIO *out=NULL; + + const char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email=""; + char *keyout,*pemout,*str; + int keysize,serial=0,days=365; + + if ((objc<5) || (objc>6)) { + Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) { + return TCL_ERROR; + } + keyout=Tcl_GetString(objv[3]); + pemout=Tcl_GetString(objv[4]); + + if (objc>=6) { + if (Tcl_ListObjGetElements(interp, objv[5], + &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + + if ((listc%2) != 0) { + Tcl_SetResult(interp,"Information list must have even number of arguments",NULL); + return TCL_ERROR; + } + for (i=0; i 8 +Tls_Free( void *blockPtr ) +#else +Tls_Free( char *blockPtr ) +#endif +{ + State *statePtr = (State *)blockPtr; + + dprintf("Called"); + + Tls_Clean(statePtr); + ckfree(blockPtr); +} + +/* + *------------------------------------------------------------------- + * + * Tls_Clean -- + * + * This procedure cleans up when a SSL socket based channel + * is closed and its reference count falls below 1. This should + * be called synchronously by the CloseProc, not in the + * EventuallyFree callback. + * + * Results: + * none + * + * Side effects: + * Frees all the state + * + *------------------------------------------------------------------- + */ +void Tls_Clean(State *statePtr) { + dprintf("Called"); + + /* + * we're assuming here that we're single-threaded + */ + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = NULL; + } + + if (statePtr->bio) { + /* This will call SSL_shutdown. Bug 1414045 */ + dprintf("BIO_free_all(%p)", statePtr->bio); + BIO_free_all(statePtr->bio); + statePtr->bio = NULL; + } + if (statePtr->ssl) { + dprintf("SSL_free(%p)", statePtr->ssl); + SSL_free(statePtr->ssl); + statePtr->ssl = NULL; + } + if (statePtr->ctx) { + SSL_CTX_free(statePtr->ctx); + statePtr->ctx = NULL; + } + if (statePtr->callback) { + Tcl_DecrRefCount(statePtr->callback); + statePtr->callback = NULL; + } + if (statePtr->password) { + Tcl_DecrRefCount(statePtr->password); + statePtr->password = NULL; + } + + dprintf("Returning"); +} + +/* + *------------------------------------------------------------------- + * + * Tls_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: Ssl configured and loaded + * + * Side effects: + * create the ssl command, initialise ssl context + * + *------------------------------------------------------------------- + */ + +DLLEXPORT int Tls_Init(Tcl_Interp *interp) { + const char tlsTclInitScript[] = { +#include "tls.tcl.h" + 0x00 + }; + + dprintf("Called"); + + /* + * We only support Tcl 8.4 or newer + */ + if ( +#ifdef USE_TCL_STUBS + Tcl_InitStubs(interp, "8.6-", 0) +#else + Tcl_PkgRequire(interp, "Tcl", "8.6-", 0) +#endif + == NULL) { + return TCL_ERROR; + } + + if (TlsLibInit(0) != TCL_OK) { + Tcl_AppendResult(interp, "could not initialize SSL library", (char *)NULL); + return TCL_ERROR; + } + + Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + if (interp) { + Tcl_Eval(interp, tlsTclInitScript); + } + + return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION)); +} + +/* + *------------------------------------------------------* + * + * Tls_SafeInit -- + * + * ------------------------------------------------* + * Standard procedure required by 'load'. + * Initializes this extension for a safe interpreter. + * ------------------------------------------------* + * + * Sideeffects: + * As of 'Tls_Init' + * + * Result: + * A standard Tcl error code. + * + *------------------------------------------------------* + */ + +DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp) { + dprintf("Called"); + return(Tls_Init(interp)); +} + +/* + *------------------------------------------------------* + * + * TlsLibInit -- + * + * ------------------------------------------------* + * Initializes SSL library once per application + * ------------------------------------------------* + * + * Side effects: + * initilizes SSL library + * + * Result: + * none + * + *------------------------------------------------------* + */ +static int TlsLibInit(int uninitialize) { + static int initialized = 0; + int status = TCL_OK; +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + size_t num_locks; +#endif + + if (uninitialize) { + if (!initialized) { + dprintf("Asked to uninitialize, but we are not initialized"); + + return(TCL_OK); + } + + dprintf("Asked to uninitialize"); + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexLock(&init_mx); + + CRYPTO_set_locking_callback(NULL); + CRYPTO_set_id_callback(NULL); + + if (locks) { + free(locks); + locks = NULL; + locksCount = 0; + } +#endif + initialized = 0; + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexUnlock(&init_mx); +#endif + + return(TCL_OK); + } + + if (initialized) { + dprintf("Called, but using cached value"); + return(status); + } + + dprintf("Called"); + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexLock(&init_mx); +#endif + initialized = 1; + +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + num_locks = CRYPTO_num_locks(); + locksCount = num_locks; + locks = malloc(sizeof(*locks) * num_locks); + memset(locks, 0, sizeof(*locks) * num_locks); + + CRYPTO_set_locking_callback(CryptoThreadLockCallback); + CRYPTO_set_id_callback(CryptoThreadIdCallback); +#endif + + if (SSL_library_init() != 1) { + status = TCL_ERROR; + goto done; + } + + SSL_load_error_strings(); + ERR_load_crypto_strings(); + + BIO_new_tcl(NULL, 0); + +#if 0 + /* + * XXX:TODO: Remove this code and replace it with a check + * for enough entropy and do not try to create our own + * terrible entropy + */ + /* + * Seed the random number generator in the SSL library, + * using the do/while construct because of the bug note in the + * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1 + * + * The crux of the problem is that Solaris 7 does not have a + * /dev/random or /dev/urandom device so it cannot gather enough + * entropy from the RAND_seed() when TLS initializes and refuses + * to go further. Earlier versions of OpenSSL carried on regardless. + */ + srand((unsigned int) time((time_t *) NULL)); + do { + for (i = 0; i < 16; i++) { + rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0)); + } + RAND_seed(rnd_seed, sizeof(rnd_seed)); + } while (RAND_status() != 1); +#endif + +done: +#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) + Tcl_MutexUnlock(&init_mx); +#endif + + return(status); +} ADDED generic/tls.h Index: generic/tls.h ================================================================== --- /dev/null +++ generic/tls.h @@ -0,0 +1,29 @@ +/* + * Copyright (C) 1997-2000 Matt Newman + * + * TLS (aka SSL) Channel - can be layered on any bi-directional + * Tcl_Channel (Note: Requires Trf Core Patch) + * + * This was built from scratch based upon observation of OpenSSL 0.9.2B + * + * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for + * providing the Tcl_ReplaceChannel mechanism and working closely with me + * to enhance it to support full fileevent semantics. + * + * Also work done by the follow people provided the impetus to do this "right":- + * tclSSL (Colin McCormack, Shared Technology) + * SSLtcl (Peter Antman) + * + */ +#ifndef _TLS_H +#define _TLS_H + +#include + +/* + * Initialization routines -- our entire public C API. + */ +DLLEXPORT int Tls_Init(Tcl_Interp *interp); +DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp); + +#endif /* _TLS_H */ ADDED generic/tlsBIO.c Index: generic/tlsBIO.c ================================================================== --- /dev/null +++ generic/tlsBIO.c @@ -0,0 +1,323 @@ +/* + * Copyright (C) 1997-2000 Matt Newman + * + * Provides BIO layer to interface openssl to Tcl. + */ + +#include "tlsInt.h" + +#ifdef TCLTLS_OPENSSL_PRE_1_1_API +#define BIO_get_data(bio) ((bio)->ptr) +#define BIO_get_init(bio) ((bio)->init) +#define BIO_get_shutdown(bio) ((bio)->shutdown) +#define BIO_set_data(bio, val) (bio)->ptr = (val) +#define BIO_set_init(bio, val) (bio)->init = (val) +#define BIO_set_shutdown(bio, val) (bio)->shutdown = (val) + +/* XXX: This assumes the variable being assigned to is BioMethods */ +#define BIO_meth_new(type_, name_) (BIO_METHOD *)Tcl_Alloc(sizeof(BIO_METHOD)); \ + memset(BioMethods, 0, sizeof(BIO_METHOD)); \ + BioMethods->type = type_; \ + BioMethods->name = name_; +#define BIO_meth_set_write(bio, val) (bio)->bwrite = val; +#define BIO_meth_set_read(bio, val) (bio)->bread = val; +#define BIO_meth_set_puts(bio, val) (bio)->bputs = val; +#define BIO_meth_set_ctrl(bio, val) (bio)->ctrl = val; +#define BIO_meth_set_create(bio, val) (bio)->create = val; +#define BIO_meth_set_destroy(bio, val) (bio)->destroy = val; +#endif + +/* + * Forward declarations + */ + +static int BioWrite (BIO *h, const char *buf, int num); +static int BioRead (BIO *h, char *buf, int num); +static int BioPuts (BIO *h, const char *str); +static long BioCtrl (BIO *h, int cmd, long arg1, void *ptr); +static int BioNew (BIO *h); +static int BioFree (BIO *h); + +BIO *BIO_new_tcl(State *statePtr, int flags) { + BIO *bio; + static BIO_METHOD *BioMethods = NULL; +#ifdef TCLTLS_SSL_USE_FASTPATH + Tcl_Channel parentChannel; + const Tcl_ChannelType *parentChannelType; + void *parentChannelFdIn_p, *parentChannelFdOut_p; + int parentChannelFdIn, parentChannelFdOut, parentChannelFd; + int validParentChannelFd; + int tclGetChannelHandleRet; +#endif + + dprintf("BIO_new_tcl() called"); + + if (BioMethods == NULL) { + BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl"); + BIO_meth_set_write(BioMethods, BioWrite); + BIO_meth_set_read(BioMethods, BioRead); + BIO_meth_set_puts(BioMethods, BioPuts); + BIO_meth_set_ctrl(BioMethods, BioCtrl); + BIO_meth_set_create(BioMethods, BioNew); + BIO_meth_set_destroy(BioMethods, BioFree); + } + + if (statePtr == NULL) { + dprintf("Asked to setup a NULL state, just creating the initial configuration"); + + return(NULL); + } + +#ifdef TCLTLS_SSL_USE_FASTPATH + /* + * If the channel can be mapped back to a file descriptor, just use the file descriptor + * with the SSL library since it will likely be optimized for this. + */ + parentChannel = Tls_GetParent(statePtr, 0); + parentChannelType = Tcl_GetChannelType(parentChannel); + + validParentChannelFd = 0; + if (strcmp(parentChannelType->typeName, "tcp") == 0) { + tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, &parentChannelFdIn_p); + if (tclGetChannelHandleRet == TCL_OK) { + tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, &parentChannelFdOut_p); + if (tclGetChannelHandleRet == TCL_OK) { + parentChannelFdIn = PTR2INT(parentChannelFdIn_p); + parentChannelFdOut = PTR2INT(parentChannelFdOut_p); + if (parentChannelFdIn == parentChannelFdOut) { + parentChannelFd = parentChannelFdIn; + validParentChannelFd = 1; + } + } + } + } + + if (validParentChannelFd) { + dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn); + bio = BIO_new_socket(parentChannelFd, flags); + statePtr->flags |= TLS_TCL_FASTPATH; + return(bio); + } + + dprintf("Falling back to Tcl I/O for this channel"); +#endif + + bio = BIO_new(BioMethods); + BIO_set_data(bio, statePtr); + BIO_set_shutdown(bio, flags); + BIO_set_init(bio, 1); + + return(bio); +} + +static int BioWrite(BIO *bio, const char *buf, int bufLen) { + Tcl_Channel chan; + int ret; + int tclEofChan, tclErrno; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("[chan=%p] BioWrite(%p, , %d)", (void *)chan, (void *) bio, bufLen); + + ret = Tcl_WriteRaw(chan, buf, bufLen); + + tclEofChan = Tcl_Eof(chan); + tclErrno = Tcl_GetErrno(); + + dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno()); + + BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY); + + if (tclEofChan && ret <= 0) { + dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF"); + Tcl_SetErrno(ECONNRESET); + ret = 0; + } else if (ret == 0) { + dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0"); + dprintf("Setting retry read flag"); + BIO_set_retry_read(bio); + } else if (ret < 0) { + dprintf("We got some kind of I/O error"); + + if (tclErrno == EAGAIN) { + dprintf("It's EAGAIN"); + } else { + dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); + } + } else { + dprintf("Successfully wrote some data"); + } + + if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) { + if (BIO_should_read(bio)) { + dprintf("Setting should retry read flag"); + + BIO_set_retry_read(bio); + } + } + + return(ret); +} + +static int BioRead(BIO *bio, char *buf, int bufLen) { + Tcl_Channel chan; + int ret = 0; + int tclEofChan, tclErrno; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("[chan=%p] BioRead(%p, , %d)", (void *) chan, (void *) bio, bufLen); + + if (buf == NULL) { + return 0; + } + + ret = Tcl_ReadRaw(chan, buf, bufLen); + + tclEofChan = Tcl_Eof(chan); + tclErrno = Tcl_GetErrno(); + + dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno); + + BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY); + + if (tclEofChan && ret <= 0) { + dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF"); + Tcl_SetErrno(ECONNRESET); + ret = 0; + } else if (ret == 0) { + dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0"); + dprintf("Setting retry read flag"); + BIO_set_retry_read(bio); + } else if (ret < 0) { + dprintf("We got some kind of I/O error"); + + if (tclErrno == EAGAIN) { + dprintf("It's EAGAIN"); + } else { + dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); + } + } else { + dprintf("Successfully read some data"); + } + + if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) { + if (BIO_should_write(bio)) { + dprintf("Setting should retry write flag"); + + BIO_set_retry_write(bio); + } + } + + dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret); + + return(ret); +} + +static int BioPuts(BIO *bio, const char *str) { + dprintf("BioPuts(%p, ) called", bio, str); + + return BioWrite(bio, str, (int) strlen(str)); +} + +static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) { + Tcl_Channel chan; + long ret = 1; + + chan = Tls_GetParent((State *) BIO_get_data(bio), 0); + + dprintf("BioCtrl(%p, 0x%x, 0x%lx, %p)", bio, cmd, num, ptr); + + switch (cmd) { + case BIO_CTRL_RESET: + dprintf("Got BIO_CTRL_RESET"); + num = 0; + ret = 0; + break; + case BIO_C_FILE_SEEK: + dprintf("Got BIO_C_FILE_SEEK"); + ret = 0; + break; + case BIO_C_FILE_TELL: + dprintf("Got BIO_C_FILE_TELL"); + ret = 0; + break; + case BIO_CTRL_INFO: + dprintf("Got BIO_CTRL_INFO"); + ret = 1; + break; + case BIO_C_SET_FD: + dprintf("Unsupported call: BIO_C_SET_FD"); + ret = -1; + break; + case BIO_C_GET_FD: + dprintf("Unsupported call: BIO_C_GET_FD"); + ret = -1; + break; + case BIO_CTRL_GET_CLOSE: + dprintf("Got BIO_CTRL_CLOSE"); + ret = BIO_get_shutdown(bio); + break; + case BIO_CTRL_SET_CLOSE: + dprintf("Got BIO_SET_CLOSE"); + BIO_set_shutdown(bio, num); + break; + case BIO_CTRL_EOF: + dprintf("Got BIO_CTRL_EOF"); + ret = Tcl_Eof(chan); + break; + case BIO_CTRL_PENDING: + dprintf("Got BIO_CTRL_PENDING"); + ret = ((chan) ? Tcl_InputBuffered(chan) : 0); + dprintf("BIO_CTRL_PENDING(%d)", (int) ret); + break; + case BIO_CTRL_WPENDING: + dprintf("Got BIO_CTRL_WPENDING"); + ret = 0; + break; + case BIO_CTRL_DUP: + dprintf("Got BIO_CTRL_DUP"); + break; + case BIO_CTRL_FLUSH: + dprintf("Got BIO_CTRL_FLUSH"); + ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); + dprintf("BIO_CTRL_FLUSH returning value %li", ret); + break; + default: + dprintf("Got unknown control command (%i)", cmd); + ret = -2; + break; + } + + return(ret); +} + +static int BioNew(BIO *bio) { + dprintf("BioNew(%p) called", bio); + + BIO_set_init(bio, 0); + BIO_set_data(bio, NULL); + BIO_clear_flags(bio, -1); + + return(1); +} + +static int BioFree(BIO *bio) { + if (bio == NULL) { + return(0); + } + + dprintf("BioFree(%p) called", bio); + + if (BIO_get_shutdown(bio)) { + if (BIO_get_init(bio)) { + /*shutdown(bio->num, 2) */ + /*closesocket(bio->num) */ + } + + BIO_set_init(bio, 0); + BIO_clear_flags(bio, -1); + } + + return(1); +} ADDED generic/tlsIO.c Index: generic/tlsIO.c ================================================================== --- /dev/null +++ generic/tlsIO.c @@ -0,0 +1,946 @@ +/* + * Copyright (C) 1997-2000 Matt Newman + * Copyright (C) 2000 Ajuba Solutions + * + * TLS (aka SSL) Channel - can be layered on any bi-directional + * Tcl_Channel (Note: Requires Trf Core Patch) + * + * This was built from scratch based upon observation of OpenSSL 0.9.2B + * + * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for + * providing the Tcl_ReplaceChannel mechanism and working closely with me + * to enhance it to support full fileevent semantics. + * + * Also work done by the follow people provided the impetus to do this "right": + * tclSSL (Colin McCormack, Shared Technology) + * SSLtcl (Peter Antman) + * + */ + +#include "tlsInt.h" + +/* + * Forward declarations + */ +static int TlsBlockModeProc (void *instanceData, int mode); +static int TlsCloseProc (void *instanceData, Tcl_Interp *interp); +static int TlsClose2Proc (void *instanceData, Tcl_Interp *interp, int flags); +static int TlsInputProc (void *instanceData, char *buf, int bufSize, int *errorCodePtr); +static int TlsOutputProc (void *instanceData, const char *buf, int toWrite, int *errorCodePtr); +static int TlsGetOptionProc (void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); +static void TlsWatchProc (void *instanceData, int mask); +static int TlsGetHandleProc (void *instanceData, int direction, void **handlePtr); +static int TlsNotifyProc (void *instanceData, int mask); +static void TlsChannelHandlerTimer (void *clientData); + +/* + * TLS Channel Type + */ +static const Tcl_ChannelType tlsChannelType = { + "tls", /* typeName */ + TCL_CHANNEL_VERSION_5, /* version */ + TlsCloseProc, /* closeProc */ + TlsInputProc, /* inputProc */ + TlsOutputProc, /* outputProc */ + 0, /* seekProc */ + 0, /* setOptionProc */ + TlsGetOptionProc, /* getOptionProc */ + TlsWatchProc, /* watchProc */ + TlsGetHandleProc, /* getHandleProc */ + TlsClose2Proc, /* close2Proc */ + TlsBlockModeProc, /* blockModeProc */ + 0, /* flushProc */ + TlsNotifyProc, /* handlerProc */ + 0, /* wideSeekProc */ + 0, /* threadActionProc */ + 0 /* truncateProc */ +}; + + +/* + *------------------------------------------------------------------- + * + * Tls_ChannelType -- + * + * Return the correct TLS channel driver info + * + * Results: + * The correct channel driver for the current version of Tcl. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +const Tcl_ChannelType *Tls_ChannelType(void) { + return &tlsChannelType; +} + +/* + *------------------------------------------------------------------- + * + * TlsBlockModeProc -- + * + * This procedure is invoked by the generic IO level + * to set blocking and nonblocking modes + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or nonblocking mode. + * + *------------------------------------------------------------------- + */ +static int TlsBlockModeProc(void *instanceData, int mode) { + State *statePtr = (State *) instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + statePtr->flags |= TLS_TCL_ASYNC; + } else { + statePtr->flags &= ~(TLS_TCL_ASYNC); + } + + return(0); +} + +/* + *------------------------------------------------------------------- + * + * TlsCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a SSL socket based channel + * is closed. + * + * Note: we leave the underlying socket alone, is this right? + * + * Results: + * 0 if successful, the value of Tcl_GetErrno() if failed. + * + * Side effects: + * Closes the socket of the channel. + * + *------------------------------------------------------------------- + */ +static int TlsCloseProc(void *instanceData, TCL_UNUSED(Tcl_Interp *)) { + State *statePtr = (State *) instanceData; + + dprintf("TlsCloseProc(%p)", statePtr); + + Tls_Clean(statePtr); + Tcl_EventuallyFree(statePtr, Tls_Free); + + dprintf("Returning TCL_OK"); + + return(TCL_OK); +} + +static int TlsClose2Proc(void *instanceData, Tcl_Interp *interp, int flags) { + if (!(flags&(TCL_CLOSE_READ|TCL_CLOSE_WRITE))) { + return TlsCloseProc(instanceData, interp); + } + return EINVAL; +} + +/* + *------------------------------------------------------* + * + * Tls_WaitForConnect -- + * + * Sideeffects: + * Issues SSL_accept or SSL_connect + * + * Result: + * None. + * + *------------------------------------------------------* + */ +int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) { + unsigned long backingError; + int err, rc; + int bioShouldRetry; + + dprintf("WaitForConnect(%p)", statePtr); + dprintFlags(statePtr); + + if (!(statePtr->flags & TLS_TCL_INIT)) { + dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success"); + *errorCodePtr = 0; + return(0); + } + + if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { + /* + * Different types of operations have different requirements + * SSL being established + */ + if (handshakeFailureIsPermanent) { + dprintf("Asked to wait for a TLS handshake that has already failed. Returning fatal error"); + *errorCodePtr = ECONNABORTED; + } else { + dprintf("Asked to wait for a TLS handshake that has already failed. Returning soft error"); + *errorCodePtr = ECONNRESET; + } + return(-1); + } + + for (;;) { + /* Not initialized yet! */ + if (statePtr->flags & TLS_TCL_SERVER) { + dprintf("Calling SSL_accept()"); + + err = SSL_accept(statePtr->ssl); + } else { + dprintf("Calling SSL_connect()"); + + err = SSL_connect(statePtr->ssl); + } + + if (err > 0) { + dprintf("That seems to have gone okay"); + + err = BIO_flush(statePtr->bio); + + if (err <= 0) { + dprintf("Flushing the lower layers failed, this will probably terminate this session"); + } + } + + rc = SSL_get_error(statePtr->ssl, err); + + dprintf("Got error: %i (rc = %i)", err, rc); + + bioShouldRetry = 0; + if (err <= 0) { + if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT || rc == SSL_ERROR_WANT_READ || rc == SSL_ERROR_WANT_WRITE) { + bioShouldRetry = 1; + } else if (BIO_should_retry(statePtr->bio)) { + bioShouldRetry = 1; + } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) { + bioShouldRetry = 1; + } + } else { + if (!SSL_is_init_finished(statePtr->ssl)) { + bioShouldRetry = 1; + } + } + + if (bioShouldRetry) { + dprintf("The I/O did not complete -- but we should try it again"); + + if (statePtr->flags & TLS_TCL_ASYNC) { + dprintf("Returning EAGAIN so that it can be retried later"); + + *errorCodePtr = EAGAIN; + + return(-1); + } else { + dprintf("Doing so now"); + + continue; + } + } + + dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though"); + break; + } + + + *errorCodePtr = EINVAL; + + switch (rc) { + case SSL_ERROR_NONE: + /* The connection is up, we are done here */ + dprintf("The connection is up"); + break; + case SSL_ERROR_ZERO_RETURN: + dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...") + return(-1); + case SSL_ERROR_SYSCALL: + backingError = ERR_get_error(); + + if (backingError == 0 && err == 0) { + dprintf("EOF reached") + *errorCodePtr = ECONNRESET; + } else if (backingError == 0 && err == -1) { + dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); + *errorCodePtr = Tcl_GetErrno(); + if (*errorCodePtr == ECONNRESET) { + *errorCodePtr = ECONNABORTED; + } + } else { + dprintf("I/O error occured (backingError = %lu)", backingError); + *errorCodePtr = backingError; + if (*errorCodePtr == ECONNRESET) { + *errorCodePtr = ECONNABORTED; + } + } + + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + + return(-1); + case SSL_ERROR_SSL: + dprintf("Got permanent fatal SSL error, aborting immediately"); + Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error())); + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + *errorCodePtr = ECONNABORTED; + return(-1); + case SSL_ERROR_WANT_CONNECT: + case SSL_ERROR_WANT_ACCEPT: + case SSL_ERROR_WANT_X509_LOOKUP: + default: + dprintf("We got a confusing reply: %i", rc); + *errorCodePtr = Tcl_GetErrno(); + dprintf("ERR(%d, %d) ", rc, *errorCodePtr); + return(-1); + } + +#if 0 + if (statePtr->flags & TLS_TCL_SERVER) { + dprintf("This is an TLS server, checking the certificate for the peer"); + + err = SSL_get_verify_result(statePtr->ssl); + if (err != X509_V_OK) { + dprintf("Invalid certificate, returning in failure"); + + Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err)); + statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; + *errorCodePtr = ECONNABORTED; + return(-1); + } + } +#endif + + dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake"); + statePtr->flags &= ~TLS_TCL_INIT; + + dprintf("Returning in success"); + *errorCodePtr = 0; + + return(0); +} + +/* + *------------------------------------------------------------------- + * + * TlsInputProc -- + * + * This procedure is invoked by the generic IO level + * to read input from a SSL socket based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no + * error occurred. + * + * Side effects: + * Reads input from the input device of the channel. + * + *------------------------------------------------------------------- + */ + +static int TlsInputProc(void *instanceData, char *buf, int bufSize, int *errorCodePtr) { + unsigned long backingError; + State *statePtr = (State *) instanceData; + int bytesRead; + int tlsConnect; + int err; + + *errorCodePtr = 0; + + dprintf("BIO_read(%d)", bufSize); + + if (statePtr->flags & TLS_TCL_CALLBACK) { + /* don't process any bytes while verify callback is running */ + dprintf("Callback is running, reading 0 bytes"); + return(0); + } + + dprintf("Calling Tls_WaitForConnect"); + tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0); + if (tlsConnect < 0) { + dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr); + + bytesRead = -1; + if (*errorCodePtr == ECONNRESET) { + dprintf("Got connection reset"); + /* Soft EOF */ + *errorCodePtr = 0; + bytesRead = 0; + } + + return(bytesRead); + } + + /* + * We need to clear the SSL error stack now because we sometimes reach + * this function with leftover errors in the stack. If BIO_read + * returns -1 and intends EAGAIN, there is a leftover error, it will be + * misconstrued as an error, not EAGAIN. + * + * Alternatively, we may want to handle the <0 return codes from + * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO + * functions play with the retry flags though, and this seems to work + * correctly. Similar fix in TlsOutputProc. - hobbs + */ + ERR_clear_error(); + bytesRead = BIO_read(statePtr->bio, buf, bufSize); + dprintf("BIO_read -> %d", bytesRead); + + err = SSL_get_error(statePtr->ssl, bytesRead); + +#if 0 + if (bytesRead <= 0) { + if (BIO_should_retry(statePtr->bio)) { + dprintf("I/O failed, will retry based on EAGAIN"); + *errorCodePtr = EAGAIN; + } + } +#endif + + switch (err) { + case SSL_ERROR_NONE: + dprintBuffer(buf, bytesRead); + break; + case SSL_ERROR_SSL: + dprintf("SSL negotiation error, indicating that the connection has been aborted"); + + Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead)); + *errorCodePtr = ECONNABORTED; + bytesRead = -1; + + break; + case SSL_ERROR_SYSCALL: + backingError = ERR_get_error(); + + if (backingError == 0 && bytesRead == 0) { + dprintf("EOF reached") + *errorCodePtr = 0; + bytesRead = 0; + } else if (backingError == 0 && bytesRead == -1) { + dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); + *errorCodePtr = Tcl_GetErrno(); + bytesRead = -1; + } else { + dprintf("I/O error occured (backingError = %lu)", backingError); + *errorCodePtr = backingError; + bytesRead = -1; + } + + break; + case SSL_ERROR_ZERO_RETURN: + dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached"); + bytesRead = 0; + *errorCodePtr = 0; + break; + case SSL_ERROR_WANT_READ: + dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN"); + bytesRead = -1; + *errorCodePtr = EAGAIN; + break; + default: + dprintf("Unknown error (err = %i), mapping to EOF", err); + *errorCodePtr = 0; + bytesRead = 0; + break; + } + + dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); + return(bytesRead); +} + +/* + *------------------------------------------------------------------- + * + * TlsOutputProc -- + * + * This procedure is invoked by the generic IO level + * to write output to a SSL socket based channel. + * + * Results: + * The number of bytes written is returned. An output argument is + * set to a POSIX error code if an error occurred, or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *------------------------------------------------------------------- + */ + +static int TlsOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCodePtr) { + unsigned long backingError; + State *statePtr = (State *) instanceData; + int written, err; + int tlsConnect; + + *errorCodePtr = 0; + + dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite); + dprintBuffer(buf, toWrite); + + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Don't process output while callbacks are running") + written = -1; + *errorCodePtr = EAGAIN; + return(-1); + } + + dprintf("Calling Tls_WaitForConnect"); + tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1); + if (tlsConnect < 0) { + dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr); + + written = -1; + if (*errorCodePtr == ECONNRESET) { + dprintf("Got connection reset"); + /* Soft EOF */ + *errorCodePtr = 0; + written = 0; + } + + return(written); + } + + if (toWrite == 0) { + dprintf("zero-write"); + err = BIO_flush(statePtr->bio); + + if (err <= 0) { + dprintf("Flushing failed"); + + *errorCodePtr = EIO; + written = 0; + return(-1); + } + + written = 0; + *errorCodePtr = 0; + return(0); + } + + /* + * We need to clear the SSL error stack now because we sometimes reach + * this function with leftover errors in the stack. If BIO_write + * returns -1 and intends EAGAIN, there is a leftover error, it will be + * misconstrued as an error, not EAGAIN. + * + * Alternatively, we may want to handle the <0 return codes from + * BIO_write specially (as advised in the RSA docs). TLS's lower level + * BIO functions play with the retry flags though, and this seems to + * work correctly. Similar fix in TlsInputProc. - hobbs + */ + ERR_clear_error(); + written = BIO_write(statePtr->bio, buf, toWrite); + dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written); + + err = SSL_get_error(statePtr->ssl, written); + switch (err) { + case SSL_ERROR_NONE: + if (written < 0) { + written = 0; + } + break; + case SSL_ERROR_WANT_WRITE: + dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN"); + *errorCodePtr = EAGAIN; + written = -1; + break; + case SSL_ERROR_WANT_READ: + dprintf(" write R BLOCK"); + break; + case SSL_ERROR_WANT_X509_LOOKUP: + dprintf(" write X BLOCK"); + break; + case SSL_ERROR_ZERO_RETURN: + dprintf(" closed"); + written = 0; + *errorCodePtr = 0; + break; + case SSL_ERROR_SYSCALL: + backingError = ERR_get_error(); + + if (backingError == 0 && written == 0) { + dprintf("EOF reached") + *errorCodePtr = 0; + written = 0; + } else if (backingError == 0 && written == -1) { + dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); + *errorCodePtr = Tcl_GetErrno(); + written = -1; + } else { + dprintf("I/O error occured (backingError = %lu)", backingError); + *errorCodePtr = backingError; + written = -1; + } + + break; + case SSL_ERROR_SSL: + Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written)); + *errorCodePtr = ECONNABORTED; + written = -1; + break; + default: + dprintf(" unknown err: %d", err); + break; + } + + dprintf("Output(%d) -> %d", toWrite, written); + return(written); +} + +/* + *------------------------------------------------------------------- + * + * TlsGetOptionProc -- + * + * Computes an option value for a SSL socket based channel, or a + * list of all options and their values. + * + * 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. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int +TlsGetOptionProc(void *instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For errors - can be NULL. */ + const char *optionName, /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr) /* Where to store the computed value + * initialized by caller. */ +{ + State *statePtr = (State *) instanceData; + + Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + Tcl_DriverGetOptionProc *getOptionProc; + + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + if (getOptionProc != NULL) { + return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + /* + * Request is query for all options, this is ok. + */ + return TCL_OK; + } + /* + * Request for a specific option has to fail, we don't have any. + */ + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------- + * + * TlsWatchProc -- + * + * Initialize the notifier to watch Tcl_Files 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 +TlsWatchProc(void *instanceData, /* The socket state. */ + int mask) /* Events of interest; an OR-ed + * combination of TCL_READABLE, + * TCL_WRITABLE and TCL_EXCEPTION. */ +{ + Tcl_Channel downChan; + State *statePtr = (State *) instanceData; + + dprintf("TlsWatchProc(0x%x)", mask); + + /* Pretend to be dead as long as the verify callback is running. + * Otherwise that callback could be invoked recursively. */ + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Callback is on-going, doing nothing"); + return; + } + + dprintFlags(statePtr); + + downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); + + if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { + dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here"); + + dprintf("Unregistering interest in the lower channel"); + (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0); + + statePtr->watchMask = 0; + + return; + } + + statePtr->watchMask = mask; + + /* No channel handlers any more. We will be notified automatically + * about events on the channel below via a call to our + * 'TransformNotifyProc'. But we have to pass the interest down now. + * We are allowed to add additional 'interest' to the mask if we want + * to. But this transformation has no such interest. It just passes + * the request down, unchanged. + */ + + + dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan); + (Tcl_GetChannelType(downChan)) + ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + + /* + * Management of the internal timer. + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + dprintf("A timer was found, deleting it"); + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + + if (mask & TCL_READABLE) { + if (Tcl_InputBuffered(statePtr->self) > 0 || BIO_ctrl_pending(statePtr->bio) > 0) { + /* + * There is interest in readable events and we actually have + * data waiting, so generate a timer to flush that. + */ + dprintf("Creating a new timer since data appears to be waiting"); + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, statePtr); + } + } +} + +/* + *------------------------------------------------------------------- + * + * TlsGetHandleProc -- + * + * Called from Tcl_GetChannelFile to retrieve o/s file handler + * from the SSL socket based channel. + * + * Results: + * The appropriate Tcl_File or NULL if not present. + * + * Side effects: + * None. + * + *------------------------------------------------------------------- + */ +static int TlsGetHandleProc(void *instanceData, int direction, void **handlePtr) { + State *statePtr = (State *) instanceData; + + return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr)); +} + +/* + *------------------------------------------------------------------- + * + * TlsNotifyProc -- + * + * Handler called by Tcl to inform us of activity + * on the underlying channel. + * + * Results: + * None. + * + * Side effects: + * May process the incoming event by itself. + * + *------------------------------------------------------------------- + */ + +static int TlsNotifyProc(void *instanceData, int mask) { + State *statePtr = (State *) instanceData; + int errorCode; + + /* + * An event occured in the underlying channel. This + * transformation doesn't process such events thus returns the + * incoming mask unchanged. + */ + if (statePtr->timer != (Tcl_TimerToken) NULL) { + /* + * Delete an existing timer. It was not fired, yet we are + * here, so the channel below generated such an event and we + * don't have to. The renewal of the interest after the + * execution of channel handlers will eventually cause us to + * recreate the timer (in WatchProc). + */ + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + + if (statePtr->flags & TLS_TCL_CALLBACK) { + dprintf("Returning 0 due to callback"); + return 0; + } + + dprintf("Calling Tls_WaitForConnect"); + errorCode = 0; + if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) { + if (errorCode == EAGAIN) { + dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0"); + + return 0; + } + + dprintf("Tls_WaitForConnect returned an error"); + } + + dprintf("Returning %i", mask); + + return(mask); +} + +#if 0 +/* + *------------------------------------------------------* + * + * TlsChannelHandler -- + * + * ------------------------------------------------* + * Handler called by Tcl as a result of + * Tcl_CreateChannelHandler - to inform us of activity + * on the underlying channel. + * ------------------------------------------------* + * + * Sideeffects: + * May generate subsequent calls to + * Tcl_NotifyChannel. + * + * Result: + * None. + * + *------------------------------------------------------* + */ + +static void +TlsChannelHandler (clientData, mask) + void * clientData; + int mask; +{ + State *statePtr = (State *) clientData; + + dprintf("HANDLER(0x%x)", mask); + Tcl_Preserve(statePtr); + + if (mask & TCL_READABLE) { + BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ); + } else { + BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ); + } + + if (mask & TCL_WRITABLE) { + BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE); + } else { + BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE); + } + + mask = 0; + if (BIO_wpending(statePtr->bio)) { + mask |= TCL_WRITABLE; + } + if (BIO_pending(statePtr->bio)) { + mask |= TCL_READABLE; + } + + /* + * The following NotifyChannel calls seems to be important, but + * we don't know why. It looks like if the mask is ever non-zero + * that it will enter an infinite loop. + * + * Notify the upper channel of the current BIO state so the event + * continues to propagate up the chain. + * + * stanton: It looks like this could result in an infinite loop if + * the upper channel doesn't cause ChannelHandler to be removed + * before Tcl_NotifyChannel calls channel handlers on the lower channel. + */ + + Tcl_NotifyChannel(statePtr->self, mask); + + if (statePtr->timer != (Tcl_TimerToken)NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken)NULL; + } + if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { + /* + * Data is waiting, flush it out in short time + */ + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, + TlsChannelHandlerTimer, statePtr); + } + Tcl_Release(statePtr); +} +#endif + +/* + *------------------------------------------------------* + * + * TlsChannelHandlerTimer -- + * + * ------------------------------------------------* + * Called by the notifier (-> timer) to flush out + * information waiting in channel buffers. + * ------------------------------------------------* + * + * Sideeffects: + * As of 'TlsChannelHandler'. + * + * Result: + * None. + * + *------------------------------------------------------* + */ + +static void TlsChannelHandlerTimer(void *clientData) { + State *statePtr = (State *) clientData; + int mask = 0; + + dprintf("Called"); + + statePtr->timer = (Tcl_TimerToken) NULL; + + if (BIO_wpending(statePtr->bio)) { + dprintf("[chan=%p] BIO writable", statePtr->self); + + mask |= TCL_WRITABLE; + } + + if (BIO_pending(statePtr->bio)) { + dprintf("[chan=%p] BIO readable", statePtr->self); + + mask |= TCL_READABLE; + } + + dprintf("Notifying ourselves"); + Tcl_NotifyChannel(statePtr->self, mask); + + dprintf("Returning"); + + return; +} + +Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) { + dprintf("Requested to get parent of channel %p", statePtr->self); + + if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) { + dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL"); + return(NULL); + } + + return(Tcl_GetStackedChannel(statePtr->self)); +} ADDED generic/tlsInt.h Index: generic/tlsInt.h ================================================================== --- /dev/null +++ generic/tlsInt.h @@ -0,0 +1,198 @@ +/* + * Copyright (C) 1997-2000 Matt Newman + * + * TLS (aka SSL) Channel - can be layered on any bi-directional + * Tcl_Channel (Note: Requires Trf Core Patch) + * + * This was built from scratch based upon observation of OpenSSL 0.9.2B + * + * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for + * providing the Tcl_ReplaceChannel mechanism and working closely with me + * to enhance it to support full fileevent semantics. + * + * Also work done by the follow people provided the impetus to do this "right":- + * tclSSL (Colin McCormack, Shared Technology) + * SSLtcl (Peter Antman) + * + */ +#ifndef _TLSINT_H +#define _TLSINT_H + +#include "tls.h" +#include +#include +#include + +#ifdef __WIN32__ +#define WIN32_LEAN_AND_MEAN +#include +#include /* OpenSSL needs this on Windows */ +#endif + +#ifdef NO_PATENTS +# define NO_IDEA +# define NO_RC2 +# define NO_RC4 +# define NO_RC5 +# define NO_RSA +# ifndef NO_SSL2 +# define NO_SSL2 +# endif +#endif + +#include +#include +#include +#include + +/* + * Determine if we should use the pre-OpenSSL 1.1.0 API + */ +#undef TCLTLS_OPENSSL_PRE_1_1 +#if (defined(LIBRESSL_VERSION_NUMBER)) || OPENSSL_VERSION_NUMBER < 0x10100000L +# define TCLTLS_OPENSSL_PRE_1_1_API 1 +#endif + +#ifndef ECONNABORTED +#define ECONNABORTED 130 /* Software caused connection abort */ +#endif +#ifndef ECONNRESET +#define ECONNRESET 131 /* Connection reset by peer */ +#endif + +#ifdef TCLEXT_TCLTLS_DEBUG +#include +#define dprintf(...) { \ + char dprintfBuffer[8192], *dprintfBuffer_p; \ + dprintfBuffer_p = &dprintfBuffer[0]; \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \ + fprintf(stderr, "%s\n", dprintfBuffer); \ + } +#define dprintBuffer(bufferName, bufferLength) { \ + int dprintBufferIdx; \ + unsigned char dprintBufferChar; \ + fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \ + for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \ + dprintBufferChar = bufferName[dprintBufferIdx]; \ + if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \ + fprintf(stderr, "'%c' ", dprintBufferChar); \ + } else { \ + fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \ + }; \ + }; \ + fprintf(stderr, "}\n"); \ + } +#define dprintFlags(statePtr) { \ + char dprintfBuffer[8192], *dprintfBuffer_p; \ + dprintfBuffer_p = &dprintfBuffer[0]; \ + dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \ + if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \ + if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \ + if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \ + if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \ + if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \ + if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \ + if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \ + fprintf(stderr, "%s\n", dprintfBuffer); \ + } +#else +#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); } +#define dprintBuffer(bufferName, bufferLength) /**/ +#define dprintFlags(statePtr) /**/ +#endif + +#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err)))) +/* + * OpenSSL BIO Routines + */ +#define BIO_TYPE_TCL (19|0x0400) + +/* + * Defines for State.flags + */ +#define TLS_TCL_ASYNC (1<<0) /* non-blocking mode */ +#define TLS_TCL_SERVER (1<<1) /* Server-Side */ +#define TLS_TCL_INIT (1<<2) /* Initializing connection */ +#define TLS_TCL_DEBUG (1<<3) /* Show debug tracing */ +#define TLS_TCL_CALLBACK (1<<4) /* In a callback, prevent update + * looping problem. [Bug 1652380] */ +#define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once + * set, all further I/O will result + * in ECONNABORTED errors. */ +#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */ +#define TLS_TCL_DELAY (5) + +/* + * This structure describes the per-instance state + * of an ssl channel. + * + * The SSL processing context is maintained here, in the ClientData + */ +typedef struct State { + Tcl_Channel self; /* this socket channel */ + Tcl_TimerToken timer; + + int flags; /* see State.flags above */ + int watchMask; /* current WatchProc mask */ + int mode; /* current mode of parent channel */ + + Tcl_Interp *interp; /* interpreter in which this resides */ + Tcl_Obj *callback; /* script called for tracing, verifying and errors */ + Tcl_Obj *password; /* script called for certificate password */ + + int vflags; /* verify flags */ + SSL *ssl; /* Struct for SSL processing */ + SSL_CTX *ctx; /* SSL Context */ + BIO *bio; /* Struct for SSL processing */ + BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */ + + const char *err; +} State; + +#ifdef USE_TCL_STUBS +#ifndef Tcl_StackChannel +#error "Unable to compile on this version of Tcl" +#endif /* Tcl_GetStackedChannel */ +#endif /* USE_TCL_STUBS */ + +#ifndef JOIN +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +#endif + +#ifndef TCL_UNUSED +# if defined(__cplusplus) +# define TCL_UNUSED(T) T +# elif defined(__GNUC__) && (__GNUC__ > 2) +# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused)) +# else +# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) +# endif +#endif + +#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) && !defined(Tcl_Size) +# define Tcl_Size int +#endif + +/* + * Forward declarations + */ +const Tcl_ChannelType *Tls_ChannelType(void); +Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags); + +Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert); +void Tls_Error(State *statePtr, char *msg); +#if TCL_MAJOR_VERSION > 8 +void Tls_Free(void *blockPtr); +#else +void Tls_Free(char *blockPtr); +#endif +void Tls_Clean(State *statePtr); +int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent); + +BIO *BIO_new_tcl(State* statePtr, int flags); + +#define PTR2INT(x) ((int) ((intptr_t) (x))) + +#endif /* _TLSINT_H */ ADDED generic/tlsX509.c Index: generic/tlsX509.c ================================================================== --- /dev/null +++ generic/tlsX509.c @@ -0,0 +1,209 @@ +/* + * Copyright (C) 1997-2000 Sensus Consulting Ltd. + * Matt Newman + */ +#include "tlsInt.h" + +/* + * Ensure these are not macros - known to be defined on Win32 + */ +#ifdef min +#undef min +#endif + +#ifdef max +#undef max +#endif + +static int min(int a, int b) +{ + return (a < b) ? a : b; +} + +static int max(int a, int b) +{ + return (a > b) ? a : b; +} + +/* + * ASN1_UTCTIME_tostr -- + */ +static char * +ASN1_UTCTIME_tostr(ASN1_UTCTIME *tm) +{ + static char bp[128]; + char *v; + int gmt=0; + static char *mon[12]={ + "Jan","Feb","Mar","Apr","May","Jun", + "Jul","Aug","Sep","Oct","Nov","Dec"}; + int i; + int y=0,M=0,d=0,h=0,m=0,s=0; + + i=tm->length; + v=(char *)tm->data; + + if (i < 10) goto err; + if (v[i-1] == 'Z') gmt=1; + for (i=0; i<10; i++) + if ((v[i] > '9') || (v[i] < '0')) goto err; + y= (v[0]-'0')*10+(v[1]-'0'); + if (y < 70) y+=100; + M= (v[2]-'0')*10+(v[3]-'0'); + if ((M > 12) || (M < 1)) goto err; + d= (v[4]-'0')*10+(v[5]-'0'); + h= (v[6]-'0')*10+(v[7]-'0'); + m= (v[8]-'0')*10+(v[9]-'0'); + if ( (v[10] >= '0') && (v[10] <= '9') && + (v[11] >= '0') && (v[11] <= '9')) + s= (v[10]-'0')*10+(v[11]-'0'); + + sprintf(bp,"%s %2d %02d:%02d:%02d %d%s", + mon[M-1],d,h,m,s,y+1900,(gmt)?" GMT":""); + return bp; + err: + return "Bad time value"; +} + +/* + *------------------------------------------------------* + * + * Tls_NewX509Obj -- + * + * ------------------------------------------------* + * Converts a X509 certificate into a Tcl_Obj + * ------------------------------------------------* + * + * Sideeffects: + * None + * + * Result: + * A Tcl List Object representing the provided + * X509 certificate. + * + *------------------------------------------------------* + */ + +#define CERT_STR_SIZE 16384 + +Tcl_Obj* +Tls_NewX509Obj( interp, cert) + Tcl_Interp *interp; + X509 *cert; +{ + Tcl_Obj *certPtr = Tcl_NewListObj( 0, NULL); + BIO *bio; + int n; + unsigned long flags; + char subject[BUFSIZ]; + char issuer[BUFSIZ]; + char serial[BUFSIZ]; + char notBefore[BUFSIZ]; + char notAfter[BUFSIZ]; + char certStr[CERT_STR_SIZE], *certStr_p; + int certStr_len, toRead; +#ifndef NO_SSL_SHA + int shai; + char sha_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1]; + unsigned char sha_hash_binary[SHA_DIGEST_LENGTH]; + const char *shachars="0123456789ABCDEF"; + + sha_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0'; +#endif + + certStr[0] = 0; + if ((bio = BIO_new(BIO_s_mem())) == NULL) { + subject[0] = 0; + issuer[0] = 0; + serial[0] = 0; + } else { + flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT; + flags &= ~ASN1_STRFLGS_ESC_MSB; + + X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags); + n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1)); + n = max(n, 0); + subject[n] = 0; + (void)BIO_flush(bio); + + X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags); + n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1)); + n = max(n, 0); + issuer[n] = 0; + (void)BIO_flush(bio); + + i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert)); + n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1)); + n = max(n, 0); + serial[n] = 0; + (void)BIO_flush(bio); + + if (PEM_write_bio_X509(bio, cert)) { + certStr_p = certStr; + certStr_len = 0; + while (1) { + toRead = min(BIO_pending(bio), CERT_STR_SIZE - certStr_len - 1); + toRead = min(toRead, BUFSIZ); + if (toRead == 0) { + break; + } + dprintf("Reading %i bytes from the certificate...", toRead); + n = BIO_read(bio, certStr_p, toRead); + if (n <= 0) { + break; + } + certStr_len += n; + certStr_p += n; + } + *certStr_p = '\0'; + (void)BIO_flush(bio); + } + + BIO_free(bio); + } + + strcpy( notBefore, ASN1_UTCTIME_tostr( X509_get_notBefore(cert) )); + strcpy( notAfter, ASN1_UTCTIME_tostr( X509_get_notAfter(cert) )); + +#ifndef NO_SSL_SHA + X509_digest(cert, EVP_sha1(), sha_hash_binary, NULL); + for (shai = 0; shai < SHA_DIGEST_LENGTH; shai++) { + sha_hash_ascii[shai * 2] = shachars[(sha_hash_binary[shai] & 0xF0) >> 4]; + sha_hash_ascii[shai * 2 + 1] = shachars[(sha_hash_binary[shai] & 0x0F)]; + } + Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha_hash_ascii, SHA_DIGEST_LENGTH * 2) ); + +#endif + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "subject", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( subject, -1) ); + + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "issuer", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( issuer, -1) ); + + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "notBefore", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( notBefore, -1) ); + + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "notAfter", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( notAfter, -1) ); + + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "serial", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( serial, -1) ); + + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( "certificate", -1) ); + Tcl_ListObjAppendElement( interp, certPtr, + Tcl_NewStringObj( certStr, -1) ); + + return certPtr; +} Index: license.terms ================================================================== --- license.terms +++ license.terms @@ -25,14 +25,14 @@ NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal +in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the -terms specified in this license. +terms specified in this license. Index: pkgIndex.tcl.in ================================================================== --- pkgIndex.tcl.in +++ pkgIndex.tcl.in @@ -1,6 +1,6 @@ -if {[package vsatisfies [package present Tcl] 8.5]} { +if {[package vsatisfies [package present Tcl] 8.6-]} { package ifneeded tls @PACKAGE_VERSION@ [list apply {{dir} { if {{@TCLEXT_BUILD@} eq "static"} { load {} Tls } else { load [file join $dir @EXTENSION_TARGET@] Tls @@ -9,8 +9,6 @@ set tlsTclInitScript [file join $dir tls.tcl] if {[file exists $tlsTclInitScript]} { source $tlsTclInitScript } }} $dir] -} elseif {[package vsatisfies [package present Tcl] 8.4]} { - package ifneeded tls @PACKAGE_VERSION@ [list load [file join $dir @EXTENSION_TARGET@] Tls] } DELETED tclOpts.h Index: tclOpts.h ================================================================== --- tclOpts.h +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright (C) 1997-2000 Matt Newman - * - * Stylized option processing - requires consitent - * external vars: opt, idx, objc, objv - */ -#ifndef _TCL_OPTS_H -#define _TCL_OPTS_H - -#define OPT_PROLOG(option) \ - if (strcmp(opt, (option)) == 0) { \ - if (++idx >= objc) { \ - Tcl_AppendResult(interp, \ - "no argument given for ", \ - (option), " option", \ - (char *) NULL); \ - return TCL_ERROR; \ - } -#define OPT_POSTLOG() \ - continue; \ - } -#define OPTOBJ(option, var) \ - OPT_PROLOG(option) \ - var = objv[idx]; \ - OPT_POSTLOG() - -#define OPTSTR(option, var) \ - OPT_PROLOG(option) \ - var = Tcl_GetStringFromObj(objv[idx], NULL);\ - OPT_POSTLOG() - -#define OPTINT(option, var) \ - OPT_PROLOG(option) \ - if (Tcl_GetIntFromObj(interp, objv[idx], \ - &(var)) != TCL_OK) { \ - return TCL_ERROR; \ - } \ - OPT_POSTLOG() - -#define OPTBOOL(option, var) \ - OPT_PROLOG(option) \ - if (Tcl_GetBooleanFromObj(interp, objv[idx],\ - &(var)) != TCL_OK) { \ - return TCL_ERROR; \ - } \ - OPT_POSTLOG() - -#define OPTBYTE(option, var, lvar) \ - OPT_PROLOG(option) \ - var = Tcl_GetByteArrayFromObj(objv[idx], &(lvar));\ - OPT_POSTLOG() - -#define OPTBAD(type, list) \ - Tcl_AppendResult(interp, "bad ", (type), \ - " \"", opt, "\": must be ", \ - (list), (char *) NULL) - -#endif /* _TCL_OPTS_H */ Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -4,11 +4,11 @@ # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. -# +# # RCS: @(#) $Id: all.tcl,v 1.5 2000/08/15 18:45:01 hobbs Exp $ #set auto_path [linsert $auto_path 0 [file normalize [file join [file dirname [info script]] ..]]] set auto_path [linsert $auto_path 0 [file normalize [pwd]]] Index: tests/oldTests/server.pem ================================================================== --- tests/oldTests/server.pem +++ tests/oldTests/server.pem @@ -269,11 +269,11 @@ cmlzYmFuZTEaMBgGA1UEChMRQ3J5cHRTb2Z0IFB0eSBMdGQxFDASBgNVBAsTC2Rl dmVsb3BtZW50MRkwFwYDVQQDExBDcnlwdFNvZnQgRGV2IENBMFwwDQYJKoZIhvcN AQEBBQADSwAwSAJBAOAOAqogG5QwAmLhzyO4CoRnx/wVy4NZP4dxJy83O1EnL0rw OdsamJKvPOLHgSXo3gDu9uVyvCf/QJmZAmC5ml8CAwEAATANBgkqhkiG9w0BAQQF AANBADRRS/GVdd7rAqRW6SdmgLJduOU2yq3avBu99kRqbp9A/dLu6r6jU+eP4oOA -TfdbFZtAAD2Hx9jUtY3tfdrJOb8= +TfdbFZtAAD2Hx9jUtY3tfdrJOb8= -----END CERTIFICATE----- -----BEGIN CERTIFICATE----- MIICVjCCAgACAQAwDQYJKoZIhvcNAQEEBQAwgbUxCzAJBgNVBAYTAkFVMRMwEQYD VQQIEwpRdWVlbnNsYW5kMREwDwYDVQQHEwhCcmlzYmFuZTEaMBgGA1UEChMRQ3J5 Index: tests/oldTests/tlsHttp.tcl ================================================================== --- tests/oldTests/tlsHttp.tcl +++ tests/oldTests/tlsHttp.tcl @@ -10,11 +10,11 @@ # # Initialize context # #tls::init -certfile client.pem -cafile server.pem -ssl2 1 -ssl3 1 -tls1 0 ;#-cipher RC4-MD5 -tls::init -cafile server.pem +tls::init -cafile server.pem # # Register with http module # http::register https 443 [list ::tls::socket -require 1] Index: tests/oldTests/tlsSrv.tcl ================================================================== --- tests/oldTests/tlsSrv.tcl +++ tests/oldTests/tlsSrv.tcl @@ -17,11 +17,11 @@ if {[catch {read $chan 1024} data]} { puts stderr "EOF ($data)" catch {close $chan} return } - + if {$verbose && $data != ""} { puts -nonewline stderr $data } if {[eof $chan]} { ;# client gone or finished puts stderr "EOF" @@ -42,13 +42,13 @@ puts [tls::status $chan] fconfigure $chan -buffering none -blocking 0 fileevent $chan readable [list reflectCB $chan 1] } -#tls::init -cafile server.pem -certfile server.pem +#tls::init -cafile server.pem -certfile server.pem tls::init -cafile server.pem -#tls::init +#tls::init set chan [tls::socket -server acceptCB \ -request 1 -require 0 1234] # -require 1 -command tls::callback 1234] Index: tests/oldTests/tlsSrv2.tcl ================================================================== --- tests/oldTests/tlsSrv2.tcl +++ tests/oldTests/tlsSrv2.tcl @@ -16,11 +16,11 @@ if {[catch {read $chan 1024} data]} { puts stderr "EOF ($data)" catch {close $chan} return } - + if {$verbose && $data != ""} { puts -nonewline stderr $data } if {[eof $chan]} { ;# client gone or finished puts stderr "EOF" Index: tests/tlsIO.test ================================================================== --- tests/tlsIO.test +++ tests/tlsIO.test @@ -3,59 +3,59 @@ # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tlsIO.test,v 1.24 2015/06/06 09:07:08 apnadkarni Exp $ # Running socket tests with a remote server: # ------------------------------------------ -# +# # Some tests in socket.test depend on the existence of a remote server to # which they connect. The remote server must be an instance of tcltest and it # must run the script found in the file "remote.tcl" in this directory. You # can start the remote server on any machine reachable from the machine on # which you want to run the socket tests, by issuing: -# +# # tcltest remote.tcl -port 8048 # Or choose another port number. -# +# # If the machine you are running the remote server on has several IP # interfaces, you can choose which interface the server listens on for # connections by specifying the -address command line flag, so: -# +# # tcltest remote.tcl -address your.machine.com -# +# # These options can also be set by environment variables. On Unix, you can # type these commands to the shell from which the remote server is started: -# +# # shell% setenv serverPort 8048 # shell% setenv serverAddress your.machine.com -# +# # and subsequently you can start the remote server with: -# +# # tcltest remote.tcl -# +# # to have it listen on port 8048 on the interface your.machine.com. -# +# # When the server starts, it prints out a detailed message containing its # configuration information, and it will block until killed with a Ctrl-C. # Once the remote server exists, you can run the tests in socket.test with # the server by setting two Tcl variables: -# +# # % set remoteServerIP # % set remoteServerPort 8048 -# +# # These variables are also settable from the environment. On Unix, you can: -# +# # shell% setenv remoteServerIP machine.where.server.runs # shell% setenv remoteServerPort 8048 -# +# # The preamble of the socket.test file checks to see if the variables are set # either in Tcl or in the environment; if they are, it attempts to connect to # the server. If the connection is successful, the tests using the remote # server will be performed; otherwise, it will attempt to start the remote # server (via exec) on platforms that support this, on the local host, @@ -566,11 +566,11 @@ set l [gets $s] if {[eof $s]} { global x close $s set x done - } else { + } else { incr i puts $s $l } } set i 0 @@ -1228,11 +1228,11 @@ proc timerproc {} { global done count c set done true set count {timer went off, eof is not sticky} close $c - } + } set count 0 set done false proc write_then_close {s} { puts $s bye close $s @@ -1463,11 +1463,11 @@ close $s1 close $s2 close $s3 sendCommand {close $socket10_9_test_server} set i -} 100 +} 100 test tlsIO-11.8 {client with several servers} {socket doTestsWithRemoteServer} { sendCertValues sendCommand { tls::init -certfile $serverCert -cafile $caCert -keyfile $serverKey @@ -1940,11 +1940,11 @@ set l [gets $s] if {[eof $s]} { global x close $s set x done - } else { + } else { incr i puts $s $l } } set i 0 @@ -1952,15 +1952,15 @@ close $f # thread cleans itself up. testthread exit } script - + # create a thread set serverthread [testthread create { source script } ] update - + after 1000 set s [tls::socket 127.0.0.1 8828] fconfigure $s -buffering line catch { @@ -1970,11 +1970,11 @@ close $s update after 2000 lappend result [threadReap] - + set result } {hello 1} test tlsIO-14.1 {test tls::unimport} {socket} { @@ -2030,16 +2030,16 @@ # Following code is based on what was reported in bug #58. Prior # to fix the program would crash with a segfault. proc Accept {sock args} { fconfigure $sock -blocking 0; fileevent $sock readable [list Handshake $sock] - } + } proc Handshake {sock} { set ::done HAND catch {tls::handshake $sock} msg set ::done $msg - } + } # NOTE: when doing an in-process client/server test, both sides need # to be non-blocking for the TLS handshake # Server - Only accept TLS 1.2 set s [tls::socket \ DELETED tls.c Index: tls.c ================================================================== --- tls.c +++ /dev/null @@ -1,1961 +0,0 @@ -/* - * Copyright (C) 1997-1999 Matt Newman - * some modifications: - * Copyright (C) 2000 Ajuba Solutions - * Copyright (C) 2002 ActiveState Corporation - * Copyright (C) 2004 Starfish Systems - * - * TLS (aka SSL) Channel - can be layered on any bi-directional - * Tcl_Channel (Note: Requires Trf Core Patch) - * - * This was built (almost) from scratch based upon observation of - * OpenSSL 0.9.2B - * - * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for - * providing the Tcl_ReplaceChannel mechanism and working closely with me - * to enhance it to support full fileevent semantics. - * - * Also work done by the follow people provided the impetus to do this "right": - * tclSSL (Colin McCormack, Shared Technology) - * SSLtcl (Peter Antman) - * - */ - -#include "tlsInt.h" -#include "tclOpts.h" -#include - -/* - * External functions - */ - -/* - * Forward declarations - */ - -#define F2N( key, dsp) \ - (((key) == NULL) ? (char *) NULL : \ - Tcl_TranslateFileName(interp, (key), (dsp))) -#define REASON() ERR_reason_error_string(ERR_get_error()) - -static void InfoCallback(CONST SSL *ssl, int where, int ret); - -static int CiphersObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int HandshakeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int ImportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int StatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int VersionObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int MiscObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static int UnimportObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); - -static SSL_CTX *CTX_Init(State *statePtr, int isServer, int proto, char *key, - char *certfile, unsigned char *key_asn1, unsigned char *cert_asn1, - int key_asn1_len, int cert_asn1_len, char *CAdir, char *CAfile, - char *ciphers, char *DHparams); - -static int TlsLibInit(int uninitialize); - -#define TLS_PROTO_SSL2 0x01 -#define TLS_PROTO_SSL3 0x02 -#define TLS_PROTO_TLS1 0x04 -#define TLS_PROTO_TLS1_1 0x08 -#define TLS_PROTO_TLS1_2 0x10 -#define TLS_PROTO_TLS1_3 0x20 -#define ENABLED(flag, mask) (((flag) & (mask)) == (mask)) - -/* - * Static data structures - */ - -#ifndef OPENSSL_NO_DH -#include "dh_params.h" -#endif - -/* - * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2 - * libraries instead of the current OpenSSL libraries. - */ - -#ifdef BSAFE -#define PRE_OPENSSL_0_9_4 1 -#endif - -/* - * Pre OpenSSL 0.9.4 Compat - */ - -#ifndef STACK_OF -#define STACK_OF(x) STACK -#define sk_SSL_CIPHER_num(sk) sk_num((sk)) -#define sk_SSL_CIPHER_value( sk, index) (SSL_CIPHER*)sk_value((sk), (index)) -#endif - -/* - * Thread-Safe TLS Code - */ - -#ifdef TCL_THREADS -#define OPENSSL_THREAD_DEFINES -#include - -#ifdef OPENSSL_THREADS -#include - -/* - * Threaded operation requires locking callbacks - * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL. - */ - -static Tcl_Mutex *locks = NULL; -static int locksCount = 0; -static Tcl_Mutex init_mx; - -void CryptoThreadLockCallback(int mode, int n, const char *file, int line) { - - if (mode & CRYPTO_LOCK) { - /* This debugging is turned off by default -- it's too noisy. */ - /* dprintf("Called to lock (n=%i of %i)", n, locksCount); */ - Tcl_MutexLock(&locks[n]); - } else { - /* dprintf("Called to unlock (n=%i of %i)", n, locksCount); */ - Tcl_MutexUnlock(&locks[n]); - } - - /* dprintf("Returning"); */ - - return; - file = file; - line = line; -} - -unsigned long CryptoThreadIdCallback(void) { - unsigned long ret; - - dprintf("Called"); - - ret = (unsigned long) Tcl_GetCurrentThread(); - - dprintf("Returning %lu", ret); - - return(ret); -} -#endif /* OPENSSL_THREADS */ -#endif /* TCL_THREADS */ - - -/* - *------------------------------------------------------------------- - * - * InfoCallback -- - * - * monitors SSL connection process - * - * Results: - * None - * - * Side effects: - * Calls callback (if defined) - *------------------------------------------------------------------- - */ -static void -InfoCallback(CONST SSL *ssl, int where, int ret) -{ - State *statePtr = (State*)SSL_get_app_data((SSL *)ssl); - Tcl_Obj *cmdPtr; - char *major; char *minor; - - dprintf("Called"); - - if (statePtr->callback == (Tcl_Obj*)NULL) - return; - - cmdPtr = Tcl_DuplicateObj(statePtr->callback); - -#if 0 - if (where & SSL_CB_ALERT) { - sev = SSL_alert_type_string_long(ret); - if (strcmp( sev, "fatal")==0) { /* Map to error */ - Tls_Error(statePtr, SSL_ERROR(ssl, 0)); - return; - } - } -#endif - if (where & SSL_CB_HANDSHAKE_START) { - major = "handshake"; - minor = "start"; - } else if (where & SSL_CB_HANDSHAKE_DONE) { - major = "handshake"; - minor = "done"; - } else { - if (where & SSL_CB_ALERT) major = "alert"; - else if (where & SSL_ST_CONNECT) major = "connect"; - else if (where & SSL_ST_ACCEPT) major = "accept"; - else major = "unknown"; - - if (where & SSL_CB_READ) minor = "read"; - else if (where & SSL_CB_WRITE) minor = "write"; - else if (where & SSL_CB_LOOP) minor = "loop"; - else if (where & SSL_CB_EXIT) minor = "exit"; - else minor = "unknown"; - } - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( "info", -1)); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( major, -1) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( minor, -1) ); - - if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) { - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); - } else if (where & SSL_CB_ALERT) { - CONST char *cp = (char *) SSL_alert_desc_string_long(ret); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( cp, -1) ); - } else { - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( SSL_state_string_long(ssl), -1) ); - } - Tcl_Preserve( (ClientData) statePtr->interp); - Tcl_Preserve( (ClientData) statePtr); - - Tcl_IncrRefCount( cmdPtr); - (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount( cmdPtr); - - Tcl_Release( (ClientData) statePtr); - Tcl_Release( (ClientData) statePtr->interp); - -} - -/* - *------------------------------------------------------------------- - * - * VerifyCallback -- - * - * Monitors SSL certificate validation process. - * This is called whenever a certificate is inspected - * or decided invalid. - * - * Results: - * A callback bound to the socket may return one of: - * 0 - the certificate is deemed invalid - * 1 - the certificate is deemed valid - * empty string - no change to certificate validation - * - * Side effects: - * The err field of the currently operative State is set - * to a string describing the SSL negotiation failure reason - *------------------------------------------------------------------- - */ -static int -VerifyCallback(int ok, X509_STORE_CTX *ctx) -{ - Tcl_Obj *cmdPtr, *result; - char *errStr, *string; - int length; - SSL *ssl = (SSL*)X509_STORE_CTX_get_ex_data(ctx, SSL_get_ex_data_X509_STORE_CTX_idx()); - X509 *cert = X509_STORE_CTX_get_current_cert(ctx); - State *statePtr = (State*)SSL_get_app_data(ssl); - int depth = X509_STORE_CTX_get_error_depth(ctx); - int err = X509_STORE_CTX_get_error(ctx); - - dprintf("Verify: %d", ok); - - if (!ok) { - errStr = (char*)X509_verify_cert_error_string(err); - } else { - errStr = (char *)0; - } - - if (statePtr->callback == (Tcl_Obj*)NULL) { - if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) { - return ok; - } else { - return 1; - } - } - cmdPtr = Tcl_DuplicateObj(statePtr->callback); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( "verify", -1)); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewIntObj( depth) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tls_NewX509Obj( statePtr->interp, cert) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewIntObj( ok) ); - - Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, - Tcl_NewStringObj( errStr ? errStr : "", -1) ); - - Tcl_Preserve( (ClientData) statePtr->interp); - Tcl_Preserve( (ClientData) statePtr); - - statePtr->flags |= TLS_TCL_CALLBACK; - - Tcl_IncrRefCount( cmdPtr); - if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { - /* It got an error - reject the certificate. */ - Tcl_BackgroundError( statePtr->interp); - ok = 0; - } else { - result = Tcl_GetObjResult(statePtr->interp); - string = Tcl_GetStringFromObj(result, &length); - /* An empty result leaves verification unchanged. */ - if (string != NULL && length > 0) { - if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) { - Tcl_BackgroundError(statePtr->interp); - ok = 0; - } - } - } - Tcl_DecrRefCount( cmdPtr); - - statePtr->flags &= ~(TLS_TCL_CALLBACK); - - Tcl_Release( (ClientData) statePtr); - Tcl_Release( (ClientData) statePtr->interp); - - return(ok); /* By default, leave verification unchanged. */ -} - -/* - *------------------------------------------------------------------- - * - * Tls_Error -- - * - * Calls callback with $fd and $msg - so the callback can decide - * what to do with errors. - * - * Side effects: - * The err field of the currently operative State is set - * to a string describing the SSL negotiation failure reason - *------------------------------------------------------------------- - */ -void -Tls_Error(State *statePtr, char *msg) -{ - Tcl_Obj *cmdPtr; - - dprintf("Called"); - - if (msg && *msg) { - Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL); - } else { - msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL); - } - statePtr->err = msg; - - if (statePtr->callback == (Tcl_Obj*)NULL) { - char buf[BUFSIZ]; - sprintf(buf, "SSL channel \"%s\": error: %s", - Tcl_GetChannelName(statePtr->self), msg); - Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE); - Tcl_BackgroundError( statePtr->interp); - return; - } - cmdPtr = Tcl_DuplicateObj(statePtr->callback); - - Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, - Tcl_NewStringObj("error", -1)); - - Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, - Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1)); - - Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, - Tcl_NewStringObj(msg, -1)); - - Tcl_Preserve((ClientData) statePtr->interp); - Tcl_Preserve((ClientData) statePtr); - - Tcl_IncrRefCount(cmdPtr); - if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { - Tcl_BackgroundError(statePtr->interp); - } - Tcl_DecrRefCount(cmdPtr); - - Tcl_Release((ClientData) statePtr); - Tcl_Release((ClientData) statePtr->interp); -} - -/* - *------------------------------------------------------------------- - * - * PasswordCallback -- - * - * Called when a password is needed to unpack RSA and PEM keys. - * Evals any bound password script and returns the result as - * the password string. - *------------------------------------------------------------------- - */ -#ifdef PRE_OPENSSL_0_9_4 -/* - * No way to handle user-data therefore no way without a global - * variable to access the Tcl interpreter. -*/ -static int -PasswordCallback(char *buf, int size, int verify) -{ - return -1; - buf = buf; - size = size; - verify = verify; -} -#else -static int -PasswordCallback(char *buf, int size, int verify, void *udata) -{ - State *statePtr = (State *) udata; - Tcl_Interp *interp = statePtr->interp; - Tcl_Obj *cmdPtr; - int result; - - dprintf("Called"); - - if (statePtr->password == NULL) { - if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL) - == TCL_OK) { - char *ret = (char *) Tcl_GetStringResult(interp); - strncpy(buf, ret, (size_t) size); - return (int)strlen(ret); - } else { - return -1; - } - } - - cmdPtr = Tcl_DuplicateObj(statePtr->password); - - Tcl_Preserve((ClientData) statePtr->interp); - Tcl_Preserve((ClientData) statePtr); - - Tcl_IncrRefCount(cmdPtr); - result = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - if (result != TCL_OK) { - Tcl_BackgroundError(statePtr->interp); - } - Tcl_DecrRefCount(cmdPtr); - - Tcl_Release((ClientData) statePtr); - Tcl_Release((ClientData) statePtr->interp); - - if (result == TCL_OK) { - char *ret = (char *) Tcl_GetStringResult(interp); - strncpy(buf, ret, (size_t) size); - return (int)strlen(ret); - } else { - return -1; - } - verify = verify; -} -#endif - -/* - *------------------------------------------------------------------- - * - * CiphersObjCmd -- list available ciphers - * - * This procedure is invoked to process the "tls::ciphers" command - * to list available ciphers, based upon protocol selected. - * - * Results: - * A standard Tcl result list. - * - * Side effects: - * constructs and destroys SSL context (CTX) - * - *------------------------------------------------------------------- - */ -static int -CiphersObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - static CONST84 char *protocols[] = { - "ssl2", "ssl3", "tls1", "tls1.1", "tls1.2", "tls1.3", NULL - }; - enum protocol { - TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_TLS1_3, TLS_NONE - }; - Tcl_Obj *objPtr; - SSL_CTX *ctx = NULL; - SSL *ssl = NULL; - STACK_OF(SSL_CIPHER) *sk; - char *cp, buf[BUFSIZ]; - int index, verbose = 0; - - dprintf("Called"); - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (objc > 2 && Tcl_GetBooleanFromObj( interp, objv[2], - &verbose) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum protocol)index) { - case TLS_SSL2: -#if defined(NO_SSL2) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(SSLv2_method()); break; -#endif - case TLS_SSL3: -#if defined(NO_SSL3) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(SSLv3_method()); break; -#endif - case TLS_TLS1: -#if defined(NO_TLS1) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(TLSv1_method()); break; -#endif - case TLS_TLS1_1: -#if defined(NO_TLS1_1) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(TLSv1_1_method()); break; -#endif - case TLS_TLS1_2: -#if defined(NO_TLS1_2) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(TLSv1_2_method()); break; -#endif - case TLS_TLS1_3: -#if defined(NO_TLS1_3) - Tcl_AppendResult(interp, "protocol not supported", NULL); - return TCL_ERROR; -#else - ctx = SSL_CTX_new(TLS_method()); break; - SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION); - SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION); -#endif - default: - break; - } - if (ctx == NULL) { - Tcl_AppendResult(interp, REASON(), (char *) NULL); - return TCL_ERROR; - } - ssl = SSL_new(ctx); - if (ssl == NULL) { - Tcl_AppendResult(interp, REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return TCL_ERROR; - } - objPtr = Tcl_NewListObj( 0, NULL); - - if (!verbose) { - for (index = 0; ; index++) { - cp = (char*)SSL_get_cipher_list( ssl, index); - if (cp == NULL) break; - Tcl_ListObjAppendElement( interp, objPtr, - Tcl_NewStringObj( cp, -1) ); - } - } else { - sk = SSL_get_ciphers(ssl); - - for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) { - register size_t i; - SSL_CIPHER_description( sk_SSL_CIPHER_value( sk, index), - buf, sizeof(buf)); - for (i = strlen(buf) - 1; i ; i--) { - if (buf[i] == ' ' || buf[i] == '\n' || - buf[i] == '\r' || buf[i] == '\t') { - buf[i] = '\0'; - } else { - break; - } - } - Tcl_ListObjAppendElement( interp, objPtr, - Tcl_NewStringObj( buf, -1) ); - } - } - SSL_free(ssl); - SSL_CTX_free(ctx); - - Tcl_SetObjResult( interp, objPtr); - return TCL_OK; - clientData = clientData; -} - -/* - *------------------------------------------------------------------- - * - * HandshakeObjCmd -- - * - * This command is used to verify whether the handshake is complete - * or not. - * - * Results: - * A standard Tcl result. 1 means handshake complete, 0 means pending. - * - * Side effects: - * May force SSL negotiation to take place. - * - *------------------------------------------------------------------- - */ - -static int HandshakeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_Channel chan; /* The channel to set a mode on. */ - State *statePtr; /* client state for ssl socket */ - CONST char *errStr = NULL; - int ret = 1; - int err = 0; - - dprintf("Called"); - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channel"); - return(TCL_ERROR); - } - - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); - if (chan == (Tcl_Channel) NULL) { - return(TCL_ERROR); - } - - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); - return(TCL_ERROR); - } - statePtr = (State *)Tcl_GetChannelInstanceData(chan); - - dprintf("Calling Tls_WaitForConnect"); - ret = Tls_WaitForConnect(statePtr, &err, 1); - dprintf("Tls_WaitForConnect returned: %i", ret); - - if ( - ret < 0 && \ - ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN) - ) { - dprintf("Async set and err = EAGAIN"); - ret = 0; - } else if (ret < 0) { - errStr = statePtr->err; - Tcl_ResetResult(interp); - Tcl_SetErrno(err); - - if (!errStr || *errStr == 0) { - errStr = Tcl_PosixError(interp); - } - - Tcl_AppendResult(interp, "handshake failed: ", errStr, (char *) NULL); - dprintf("Returning TCL_ERROR with handshake failed: %s", errStr); - return(TCL_ERROR); - } else { - if (err != 0) { - dprintf("Got an error with a completed handshake: err = %i", err); - } - - ret = 1; - } - - dprintf("Returning TCL_OK with data \"%i\"", ret); - Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); - return(TCL_OK); - - clientData = clientData; -} - -/* - *------------------------------------------------------------------- - * - * ImportObjCmd -- - * - * This procedure is invoked to process the "ssl" command - * - * The ssl command pushes SSL over a (newly connected) tcp socket - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May modify the behavior of an IO channel. - * - *------------------------------------------------------------------- - */ - -static int -ImportObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Channel chan; /* The channel to set a mode on. */ - State *statePtr; /* client state for ssl socket */ - SSL_CTX *ctx = NULL; - Tcl_Obj *script = NULL; - Tcl_Obj *password = NULL; - Tcl_DString upperChannelTranslation, upperChannelBlocking, upperChannelEncoding, upperChannelEOFChar; - int idx, len; - int flags = TLS_TCL_INIT; - int server = 0; /* is connection incoming or outgoing? */ - char *keyfile = NULL; - char *certfile = NULL; - unsigned char *key = NULL; - int key_len = 0; - unsigned char *cert = NULL; - int cert_len = 0; - char *ciphers = NULL; - char *CAfile = NULL; - char *CAdir = NULL; - char *DHparams = NULL; - char *model = NULL; -#ifndef OPENSSL_NO_TLSEXT - char *servername = NULL; /* hostname for Server Name Indication */ -#endif - int ssl2 = 0, ssl3 = 0; - int tls1 = 1, tls1_1 = 1, tls1_2 = 1, tls1_3 = 1; - int proto = 0; - int verify = 0, require = 0, request = 1; - - dprintf("Called"); - -#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL3) && !defined(NO_SSL2) - ssl2 = 1; -#endif -#if defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_SSL2) && !defined(NO_SSL3) - ssl3 = 1; -#endif -#if defined(NO_TLS1) - tls1 = 0; -#endif -#if defined(NO_TLS1_1) - tls1_1 = 0; -#endif -#if defined(NO_TLS1_2) - tls1_2 = 0; -#endif -#if defined(NO_TLS1_3) - tls1_3 = 0; -#endif - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?"); - return TCL_ERROR; - } - - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - - for (idx = 2; idx < objc; idx++) { - char *opt = Tcl_GetStringFromObj(objv[idx], NULL); - - if (opt[0] != '-') - break; - - OPTSTR( "-cadir", CAdir); - OPTSTR( "-cafile", CAfile); - OPTSTR( "-certfile", certfile); - OPTSTR( "-cipher", ciphers); - OPTOBJ( "-command", script); - OPTSTR( "-dhparams", DHparams); - OPTSTR( "-keyfile", keyfile); - OPTSTR( "-model", model); - OPTOBJ( "-password", password); - OPTBOOL( "-require", require); - OPTBOOL( "-request", request); - OPTBOOL( "-server", server); -#ifndef OPENSSL_NO_TLSEXT - OPTSTR( "-servername", servername); -#endif - - OPTBOOL( "-ssl2", ssl2); - OPTBOOL( "-ssl3", ssl3); - OPTBOOL( "-tls1", tls1); - OPTBOOL( "-tls1.1", tls1_1); - OPTBOOL( "-tls1.2", tls1_2); - OPTBOOL( "-tls1.3", tls1_3); - OPTBYTE("-cert", cert, cert_len); - OPTBYTE("-key", key, key_len); - - OPTBAD( "option", "-cadir, -cafile, -cert, -certfile, -cipher, -command, -dhparams, -key, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1, -tls1.2, or tls1.3"); - - return TCL_ERROR; - } - if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER; - if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT; - if (verify == 0) verify = SSL_VERIFY_NONE; - - proto |= (ssl2 ? TLS_PROTO_SSL2 : 0); - proto |= (ssl3 ? TLS_PROTO_SSL3 : 0); - proto |= (tls1 ? TLS_PROTO_TLS1 : 0); - proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0); - proto |= (tls1_2 ? TLS_PROTO_TLS1_2 : 0); - proto |= (tls1_3 ? TLS_PROTO_TLS1_3 : 0); - - /* reset to NULL if blank string provided */ - if (cert && !*cert) cert = NULL; - if (key && !*key) key = NULL; - if (certfile && !*certfile) certfile = NULL; - if (keyfile && !*keyfile) keyfile = NULL; - if (ciphers && !*ciphers) ciphers = NULL; - if (CAfile && !*CAfile) CAfile = NULL; - if (CAdir && !*CAdir) CAdir = NULL; - if (DHparams && !*DHparams) DHparams = NULL; - - /* new SSL state */ - statePtr = (State *) ckalloc((unsigned) sizeof(State)); - memset(statePtr, 0, sizeof(State)); - - statePtr->flags = flags; - statePtr->interp = interp; - statePtr->vflags = verify; - statePtr->err = ""; - - /* allocate script */ - if (script) { - (void) Tcl_GetStringFromObj(script, &len); - if (len) { - statePtr->callback = script; - Tcl_IncrRefCount(statePtr->callback); - } - } - - /* allocate password */ - if (password) { - (void) Tcl_GetStringFromObj(password, &len); - if (len) { - statePtr->password = password; - Tcl_IncrRefCount(statePtr->password); - } - } - - if (model != NULL) { - int mode; - /* Get the "model" context */ - chan = Tcl_GetChannel(interp, model, &mode); - if (chan == (Tcl_Channel) NULL) { - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", - Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx; - } else { - if ((ctx = CTX_Init(statePtr, server, proto, keyfile, certfile, key, - cert, key_len, cert_len, CAdir, CAfile, ciphers, - DHparams)) == (SSL_CTX*)0) { - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - } - - statePtr->ctx = ctx; - - /* - * We need to make sure that the channel works in binary (for the - * encryption not to get goofed up). - * We only want to adjust the buffering in pre-v2 channels, where - * each channel in the stack maintained its own buffers. - */ - Tcl_DStringInit(&upperChannelTranslation); - Tcl_DStringInit(&upperChannelBlocking); - Tcl_DStringInit(&upperChannelEOFChar); - Tcl_DStringInit(&upperChannelEncoding); - Tcl_GetChannelOption(interp, chan, "-eofchar", &upperChannelEOFChar); - Tcl_GetChannelOption(interp, chan, "-encoding", &upperChannelEncoding); - Tcl_GetChannelOption(interp, chan, "-translation", &upperChannelTranslation); - Tcl_GetChannelOption(interp, chan, "-blocking", &upperChannelBlocking); - Tcl_SetChannelOption(interp, chan, "-translation", "binary"); - Tcl_SetChannelOption(interp, chan, "-blocking", "true"); - dprintf("Consuming Tcl channel %s", Tcl_GetChannelName(chan)); - statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); - dprintf("Created channel named %s", Tcl_GetChannelName(statePtr->self)); - if (statePtr->self == (Tcl_Channel) NULL) { - /* - * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. - */ - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - - Tcl_SetChannelOption(interp, statePtr->self, "-translation", Tcl_DStringValue(&upperChannelTranslation)); - Tcl_SetChannelOption(interp, statePtr->self, "-encoding", Tcl_DStringValue(&upperChannelEncoding)); - Tcl_SetChannelOption(interp, statePtr->self, "-eofchar", Tcl_DStringValue(&upperChannelEOFChar)); - Tcl_SetChannelOption(interp, statePtr->self, "-blocking", Tcl_DStringValue(&upperChannelBlocking)); - - /* - * SSL Initialization - */ - - statePtr->ssl = SSL_new(statePtr->ctx); - if (!statePtr->ssl) { - /* SSL library error */ - Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(), - (char *) NULL); - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - -#ifndef OPENSSL_NO_TLSEXT - if (servername) { - if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) { - Tcl_AppendResult(interp, "setting TLS host name extension failed", - (char *) NULL); - Tls_Free((char *) statePtr); - return TCL_ERROR; - } - } -#endif - - /* - * SSL Callbacks - */ - - SSL_set_app_data(statePtr->ssl, (VOID *)statePtr); /* point back to us */ - - SSL_set_verify(statePtr->ssl, verify, VerifyCallback); - - SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback); - - /* Create Tcl_Channel BIO Handler */ - statePtr->p_bio = BIO_new_tcl(statePtr, BIO_NOCLOSE); - statePtr->bio = BIO_new(BIO_f_ssl()); - - if (server) { - statePtr->flags |= TLS_TCL_SERVER; - SSL_set_accept_state(statePtr->ssl); - } else { - SSL_set_connect_state(statePtr->ssl); - } - SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio); - BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE); - - /* - * End of SSL Init - */ - dprintf("Returning %s", Tcl_GetChannelName(statePtr->self)); - Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self), - TCL_VOLATILE); - return TCL_OK; - clientData = clientData; -} - -/* - *------------------------------------------------------------------- - * - * UnimportObjCmd -- - * - * This procedure is invoked to remove the topmost channel filter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May modify the behavior of an IO channel. - * - *------------------------------------------------------------------- - */ - -static int -UnimportObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Channel chan; /* The channel to set a mode on. */ - - dprintf("Called"); - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channel"); - return TCL_ERROR; - } - - chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - - if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), - "\": not a TLS channel", NULL); - return TCL_ERROR; - } - - if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { - return TCL_ERROR; - } - - return TCL_OK; - clientData = clientData; -} - -/* - *------------------------------------------------------------------- - * - * CTX_Init -- construct a SSL_CTX instance - * - * Results: - * A valid SSL_CTX instance or NULL. - * - * Side effects: - * constructs SSL context (CTX) - * - *------------------------------------------------------------------- - */ - -static SSL_CTX * -CTX_Init(statePtr, isServer, proto, keyfile, certfile, key, cert, - key_len, cert_len, CAdir, CAfile, ciphers, DHparams) - State *statePtr; - int isServer; - int proto; - char *keyfile; - char *certfile; - unsigned char *key; - unsigned char *cert; - int key_len; - int cert_len; - char *CAdir; - char *CAfile; - char *ciphers; - char *DHparams; -{ - Tcl_Interp *interp = statePtr->interp; - SSL_CTX *ctx = NULL; - Tcl_DString ds; - Tcl_DString ds1; - int off = 0; - int load_private_key; - const SSL_METHOD *method; - - dprintf("Called"); - - if (!proto) { - Tcl_AppendResult(interp, "no valid protocol selected", NULL); - return (SSL_CTX *)0; - } - - /* create SSL context */ -#if defined(NO_SSL2) - if (ENABLED(proto, TLS_PROTO_SSL2)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif -#if defined(NO_SSL3) - if (ENABLED(proto, TLS_PROTO_SSL3)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif -#if defined(NO_TLS1) - if (ENABLED(proto, TLS_PROTO_TLS1)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif -#if defined(NO_TLS1_1) - if (ENABLED(proto, TLS_PROTO_TLS1_1)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif -#if defined(NO_TLS1_2) - if (ENABLED(proto, TLS_PROTO_TLS1_2)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif -#if defined(NO_TLS1_3) - if (ENABLED(proto, TLS_PROTO_TLS1_3)) { - Tcl_AppendResult(interp, "protocol not supported", NULL); - return (SSL_CTX *)0; - } -#endif - - switch (proto) { -#if !defined(NO_SSL2) - case TLS_PROTO_SSL2: - method = SSLv2_method (); - break; -#endif -#if !defined(NO_SSL3) - case TLS_PROTO_SSL3: - method = SSLv3_method (); - break; -#endif -#if !defined(NO_TLS1) - case TLS_PROTO_TLS1: - method = TLSv1_method (); - break; -#endif -#if !defined(NO_TLS1_1) - case TLS_PROTO_TLS1_1: - method = TLSv1_1_method (); - break; -#endif -#if !defined(NO_TLS1_2) - case TLS_PROTO_TLS1_2: - method = TLSv1_2_method (); - break; -#endif -#if !defined(NO_TLS1_3) - case TLS_PROTO_TLS1_3: - /* - * The version range is constrained below, - * after the context is created. Use the - * generic method here. - */ - method = TLS_method (); - break; -#endif - default: -#ifdef HAVE_TLS_METHOD - method = TLS_method (); -#else - method = SSLv23_method (); -#endif -#if !defined(NO_SSL2) - off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2); -#endif -#if !defined(NO_SSL3) - off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3); -#endif -#if !defined(NO_TLS1) - off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1); -#endif -#if !defined(NO_TLS1_1) - off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1); -#endif -#if !defined(NO_TLS1_2) - off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2); -#endif -#if !defined(NO_TLS1_3) - off |= (ENABLED(proto, TLS_PROTO_TLS1_3) ? 0 : SSL_OP_NO_TLSv1_3); -#endif - break; - } - - ctx = SSL_CTX_new (method); - - if (!ctx) { - return(NULL); - } - -#if !defined(NO_TLS1_3) - if (proto == TLS_PROTO_TLS1_3) { - SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION); - SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION); - } -#endif - - SSL_CTX_set_app_data( ctx, (VOID*)interp); /* remember the interpreter */ - SSL_CTX_set_options( ctx, SSL_OP_ALL); /* all SSL bug workarounds */ - SSL_CTX_set_options( ctx, off); /* all SSL bug workarounds */ - SSL_CTX_sess_set_cache_size( ctx, 128); - - if (ciphers != NULL) - SSL_CTX_set_cipher_list(ctx, ciphers); - - /* set some callbacks */ - SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback); - -#ifndef BSAFE - SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr); -#endif - - /* read a Diffie-Hellman parameters file, or use the built-in one */ -#ifdef OPENSSL_NO_DH - if (DHparams != NULL) { - Tcl_AppendResult(interp, - "DH parameter support not available", (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } -#else - { - DH* dh; - if (DHparams != NULL) { - BIO *bio; - Tcl_DStringInit(&ds); - bio = BIO_new_file(F2N(DHparams, &ds), "r"); - if (!bio) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "Could not find DH parameters file", (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - - dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL); - BIO_free(bio); - Tcl_DStringFree(&ds); - if (!dh) { - Tcl_AppendResult(interp, - "Could not read DH parameters from file", (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - } else { - dh = get_dhParams(); - } - SSL_CTX_set_tmp_dh(ctx, dh); - DH_free(dh); - } -#endif - - /* set our certificate */ - load_private_key = 0; - if (certfile != NULL) { - load_private_key = 1; - - Tcl_DStringInit(&ds); - - if (SSL_CTX_use_certificate_file(ctx, F2N( certfile, &ds), - SSL_FILETYPE_PEM) <= 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "unable to set certificate file ", certfile, ": ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - } else if (cert != NULL) { - load_private_key = 1; - if (SSL_CTX_use_certificate_ASN1(ctx, cert_len, cert) <= 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "unable to set certificate: ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - } else { - certfile = (char*)X509_get_default_cert_file(); - - if (SSL_CTX_use_certificate_file(ctx, certfile, - SSL_FILETYPE_PEM) <= 0) { -#if 0 - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "unable to use default certificate file ", certfile, ": ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; -#endif - } - } - - /* set our private key */ - if (load_private_key) { - if (keyfile == NULL && key == NULL) { - keyfile = certfile; - } - - if (keyfile != NULL) { - /* get the private key associated with this certificate */ - if (keyfile == NULL) { - keyfile = certfile; - } - - if (SSL_CTX_use_PrivateKey_file(ctx, F2N( keyfile, &ds), SSL_FILETYPE_PEM) <= 0) { - Tcl_DStringFree(&ds); - /* flush the passphrase which might be left in the result */ - Tcl_SetResult(interp, NULL, TCL_STATIC); - Tcl_AppendResult(interp, - "unable to set public key file ", keyfile, " ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - - Tcl_DStringFree(&ds); - } else if (key != NULL) { - if (SSL_CTX_use_PrivateKey_ASN1(EVP_PKEY_RSA, ctx, key,key_len) <= 0) { - Tcl_DStringFree(&ds); - /* flush the passphrase which might be left in the result */ - Tcl_SetResult(interp, NULL, TCL_STATIC); - Tcl_AppendResult(interp, - "unable to set public key: ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - } - /* Now we know that a key and cert have been set against - * the SSL context */ - if (!SSL_CTX_check_private_key(ctx)) { - Tcl_AppendResult(interp, - "private key does not match the certificate public key", - (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; - } - } - - /* Set verification CAs */ - Tcl_DStringInit(&ds); - Tcl_DStringInit(&ds1); - if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) || - !SSL_CTX_set_default_verify_paths(ctx)) { -#if 0 - Tcl_DStringFree(&ds); - Tcl_DStringFree(&ds1); - /* Don't currently care if this fails */ - Tcl_AppendResult(interp, "SSL default verify paths: ", - REASON(), (char *) NULL); - SSL_CTX_free(ctx); - return (SSL_CTX *)0; -#endif - } - - /* https://sourceforge.net/p/tls/bugs/57/ */ - /* XXX:TODO: Let the user supply values here instead of something that exists on the filesystem */ - if ( CAfile != NULL ) { - STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file( F2N(CAfile, &ds) ); - if ( certNames != NULL ) { - SSL_CTX_set_client_CA_list(ctx, certNames ); - } - } - - Tcl_DStringFree(&ds); - Tcl_DStringFree(&ds1); - return ctx; -} - -/* - *------------------------------------------------------------------- - * - * StatusObjCmd -- return certificate for connected peer. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -static int -StatusObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - State *statePtr; - X509 *peer; - Tcl_Obj *objPtr; - Tcl_Channel chan; - char *channelName, *ciphers; - int mode; - - dprintf("Called"); - - switch (objc) { - case 2: - channelName = Tcl_GetStringFromObj(objv[1], NULL); - break; - - case 3: - if (!strcmp (Tcl_GetString (objv[1]), "-local")) { - channelName = Tcl_GetStringFromObj(objv[2], NULL); - break; - } - /* else fall... */ - default: - Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel"); - return TCL_ERROR; - } - - chan = Tcl_GetChannel(interp, channelName, &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); - if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { - Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), - "\": not a TLS channel", NULL); - return TCL_ERROR; - } - statePtr = (State *) Tcl_GetChannelInstanceData(chan); - if (objc == 2) { - peer = SSL_get_peer_certificate(statePtr->ssl); - } else { - peer = SSL_get_certificate(statePtr->ssl); - } - if (peer) { - objPtr = Tls_NewX509Obj(interp, peer); - if (objc == 2) { X509_free(peer); } - } else { - objPtr = Tcl_NewListObj(0, NULL); - } - - Tcl_ListObjAppendElement (interp, objPtr, - Tcl_NewStringObj ("sbits", -1)); - Tcl_ListObjAppendElement (interp, objPtr, - Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL))); - - ciphers = (char*)SSL_get_cipher(statePtr->ssl); - if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) { - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj("cipher", -1)); - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1)); - } - - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj("version", -1)); - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj(SSL_get_version(statePtr->ssl), -1)); - - Tcl_SetObjResult( interp, objPtr); - return TCL_OK; - clientData = clientData; -} - -/* - *------------------------------------------------------------------- - * - * VersionObjCmd -- return version string from OpenSSL. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -static int -VersionObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Obj *objPtr; - - dprintf("Called"); - - objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1); - - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; - clientData = clientData; - objc = objc; - objv = objv; -} - -/* - *------------------------------------------------------------------- - * - * MiscObjCmd -- misc commands - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -static int -MiscObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - static CONST84 char *commands [] = { "req", NULL }; - enum command { C_REQ, C_DUMMY }; - int cmd; - - dprintf("Called"); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], commands, - "command", 0,&cmd) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum command) cmd) { - case C_REQ: { - EVP_PKEY *pkey=NULL; - X509 *cert=NULL; - X509_NAME *name=NULL; - Tcl_Obj **listv; - int listc,i; - - BIO *out=NULL; - - char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email=""; - char *keyout,*pemout,*str; - int keysize,serial=0,days=365; - - if ((objc<5) || (objc>6)) { - Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?"); - return TCL_ERROR; - } - - if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) { - return TCL_ERROR; - } - keyout=Tcl_GetString(objv[3]); - pemout=Tcl_GetString(objv[4]); - - if (objc>=6) { - if (Tcl_ListObjGetElements(interp, objv[5], - &listc, &listv) != TCL_OK) { - return TCL_ERROR; - } - - if ((listc%2) != 0) { - Tcl_SetResult(interp,"Information list must have even number of arguments",NULL); - return TCL_ERROR; - } - for (i=0; itimer != (Tcl_TimerToken) NULL) { - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = NULL; - } - - if (statePtr->bio) { - /* This will call SSL_shutdown. Bug 1414045 */ - dprintf("BIO_free_all(%p)", statePtr->bio); - BIO_free_all(statePtr->bio); - statePtr->bio = NULL; - } - if (statePtr->ssl) { - dprintf("SSL_free(%p)", statePtr->ssl); - SSL_free(statePtr->ssl); - statePtr->ssl = NULL; - } - if (statePtr->ctx) { - SSL_CTX_free(statePtr->ctx); - statePtr->ctx = NULL; - } - if (statePtr->callback) { - Tcl_DecrRefCount(statePtr->callback); - statePtr->callback = NULL; - } - if (statePtr->password) { - Tcl_DecrRefCount(statePtr->password); - statePtr->password = NULL; - } - - dprintf("Returning"); -} - -/* - *------------------------------------------------------------------- - * - * Tls_Init -- - * - * This is a package initialization procedure, which is called - * by Tcl when this package is to be added to an interpreter. - * - * Results: Ssl configured and loaded - * - * Side effects: - * create the ssl command, initialise ssl context - * - *------------------------------------------------------------------- - */ - -DLLEXPORT int Tls_Init(Tcl_Interp *interp) { - const char tlsTclInitScript[] = { -#include "tls.tcl.h" - 0x00 - }; - - dprintf("Called"); - - /* - * We only support Tcl 8.4 or newer - */ - if ( -#ifdef USE_TCL_STUBS - Tcl_InitStubs(interp, "8.4", 0) -#else - Tcl_PkgRequire(interp, "Tcl", "8.4", 0) -#endif - == NULL) { - return TCL_ERROR; - } - - if (TlsLibInit(0) != TCL_OK) { - Tcl_AppendResult(interp, "could not initialize SSL library", NULL); - return TCL_ERROR; - } - - Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - - if (interp) { - Tcl_Eval(interp, tlsTclInitScript); - } - - return(Tcl_PkgProvide(interp, "tls", PACKAGE_VERSION)); -} - -/* - *------------------------------------------------------* - * - * Tls_SafeInit -- - * - * ------------------------------------------------* - * Standard procedure required by 'load'. - * Initializes this extension for a safe interpreter. - * ------------------------------------------------* - * - * Sideeffects: - * As of 'Tls_Init' - * - * Result: - * A standard Tcl error code. - * - *------------------------------------------------------* - */ - -DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp) { - dprintf("Called"); - return(Tls_Init(interp)); -} - -/* - *------------------------------------------------------* - * - * TlsLibInit -- - * - * ------------------------------------------------* - * Initializes SSL library once per application - * ------------------------------------------------* - * - * Side effects: - * initilizes SSL library - * - * Result: - * none - * - *------------------------------------------------------* - */ -static int TlsLibInit(int uninitialize) { - static int initialized = 0; - int status = TCL_OK; -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - size_t num_locks; -#endif - - if (uninitialize) { - if (!initialized) { - dprintf("Asked to uninitialize, but we are not initialized"); - - return(TCL_OK); - } - - dprintf("Asked to uninitialize"); - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - Tcl_MutexLock(&init_mx); - - CRYPTO_set_locking_callback(NULL); - CRYPTO_set_id_callback(NULL); - - if (locks) { - free(locks); - locks = NULL; - locksCount = 0; - } -#endif - initialized = 0; - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - Tcl_MutexUnlock(&init_mx); -#endif - - return(TCL_OK); - } - - if (initialized) { - dprintf("Called, but using cached value"); - return(status); - } - - dprintf("Called"); - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - Tcl_MutexLock(&init_mx); -#endif - initialized = 1; - -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - num_locks = CRYPTO_num_locks(); - locksCount = num_locks; - locks = malloc(sizeof(*locks) * num_locks); - memset(locks, 0, sizeof(*locks) * num_locks); - - CRYPTO_set_locking_callback(CryptoThreadLockCallback); - CRYPTO_set_id_callback(CryptoThreadIdCallback); -#endif - - if (SSL_library_init() != 1) { - status = TCL_ERROR; - goto done; - } - - SSL_load_error_strings(); - ERR_load_crypto_strings(); - - BIO_new_tcl(NULL, 0); - -#if 0 - /* - * XXX:TODO: Remove this code and replace it with a check - * for enough entropy and do not try to create our own - * terrible entropy - */ - /* - * Seed the random number generator in the SSL library, - * using the do/while construct because of the bug note in the - * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1 - * - * The crux of the problem is that Solaris 7 does not have a - * /dev/random or /dev/urandom device so it cannot gather enough - * entropy from the RAND_seed() when TLS initializes and refuses - * to go further. Earlier versions of OpenSSL carried on regardless. - */ - srand((unsigned int) time((time_t *) NULL)); - do { - for (i = 0; i < 16; i++) { - rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0)); - } - RAND_seed(rnd_seed, sizeof(rnd_seed)); - } while (RAND_status() != 1); -#endif - -done: -#if defined(OPENSSL_THREADS) && defined(TCL_THREADS) - Tcl_MutexUnlock(&init_mx); -#endif - - return(status); -} DELETED tls.h Index: tls.h ================================================================== --- tls.h +++ /dev/null @@ -1,29 +0,0 @@ -/* - * Copyright (C) 1997-2000 Matt Newman - * - * TLS (aka SSL) Channel - can be layered on any bi-directional - * Tcl_Channel (Note: Requires Trf Core Patch) - * - * This was built from scratch based upon observation of OpenSSL 0.9.2B - * - * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for - * providing the Tcl_ReplaceChannel mechanism and working closely with me - * to enhance it to support full fileevent semantics. - * - * Also work done by the follow people provided the impetus to do this "right":- - * tclSSL (Colin McCormack, Shared Technology) - * SSLtcl (Peter Antman) - * - */ -#ifndef _TLS_H -#define _TLS_H - -#include - -/* - * Initialization routines -- our entire public C API. - */ -DLLEXPORT int Tls_Init(Tcl_Interp *interp); -DLLEXPORT int Tls_SafeInit(Tcl_Interp *interp); - -#endif /* _TLS_H */ Index: tls.htm ================================================================== --- tls.htm +++ tls.htm @@ -1,6 +1,6 @@ - + +# Copyright (C) 1997-2000 Matt Newman # namespace eval tls { variable logcmd tclLog variable debug 0 - + # Default flags passed to tls::import variable defaults {} # Maps UID to Server Socket variable srvmap @@ -97,11 +97,11 @@ switch -- $ruleVarArgsToConsume { 0 { set argToExecute { lappend @VAR@ $arg set argsArray($arg) true - } + } } 1 { set argToExecute { incr idx if {$idx >= [llength $args]} { DELETED tlsBIO.c Index: tlsBIO.c ================================================================== --- tlsBIO.c +++ /dev/null @@ -1,319 +0,0 @@ -/* - * Copyright (C) 1997-2000 Matt Newman - * - * Provides BIO layer to interface openssl to Tcl. - */ - -#include "tlsInt.h" - -#ifdef TCLTLS_OPENSSL_PRE_1_1_API -#define BIO_get_data(bio) ((bio)->ptr) -#define BIO_get_init(bio) ((bio)->init) -#define BIO_get_shutdown(bio) ((bio)->shutdown) -#define BIO_set_data(bio, val) (bio)->ptr = (val) -#define BIO_set_init(bio, val) (bio)->init = (val) -#define BIO_set_shutdown(bio, val) (bio)->shutdown = (val) - -/* XXX: This assumes the variable being assigned to is BioMethods */ -#define BIO_meth_new(type_, name_) (BIO_METHOD *)Tcl_Alloc(sizeof(BIO_METHOD)); \ - memset(BioMethods, 0, sizeof(BIO_METHOD)); \ - BioMethods->type = type_; \ - BioMethods->name = name_; -#define BIO_meth_set_write(bio, val) (bio)->bwrite = val; -#define BIO_meth_set_read(bio, val) (bio)->bread = val; -#define BIO_meth_set_puts(bio, val) (bio)->bputs = val; -#define BIO_meth_set_ctrl(bio, val) (bio)->ctrl = val; -#define BIO_meth_set_create(bio, val) (bio)->create = val; -#define BIO_meth_set_destroy(bio, val) (bio)->destroy = val; -#endif - -/* - * Forward declarations - */ - -static int BioWrite _ANSI_ARGS_((BIO *h, CONST char *buf, int num)); -static int BioRead _ANSI_ARGS_((BIO *h, char *buf, int num)); -static int BioPuts _ANSI_ARGS_((BIO *h, CONST char *str)); -static long BioCtrl _ANSI_ARGS_((BIO *h, int cmd, long arg1, void *ptr)); -static int BioNew _ANSI_ARGS_((BIO *h)); -static int BioFree _ANSI_ARGS_((BIO *h)); - -BIO *BIO_new_tcl(State *statePtr, int flags) { - BIO *bio; - static BIO_METHOD *BioMethods = NULL; -#ifdef TCLTLS_SSL_USE_FASTPATH - Tcl_Channel parentChannel; - const Tcl_ChannelType *parentChannelType; - void *parentChannelFdIn_p, *parentChannelFdOut_p; - int parentChannelFdIn, parentChannelFdOut, parentChannelFd; - int validParentChannelFd; - int tclGetChannelHandleRet; -#endif - - dprintf("BIO_new_tcl() called"); - - if (BioMethods == NULL) { - BioMethods = BIO_meth_new(BIO_TYPE_TCL, "tcl"); - BIO_meth_set_write(BioMethods, BioWrite); - BIO_meth_set_read(BioMethods, BioRead); - BIO_meth_set_puts(BioMethods, BioPuts); - BIO_meth_set_ctrl(BioMethods, BioCtrl); - BIO_meth_set_create(BioMethods, BioNew); - BIO_meth_set_destroy(BioMethods, BioFree); - } - - if (statePtr == NULL) { - dprintf("Asked to setup a NULL state, just creating the initial configuration"); - - return(NULL); - } - -#ifdef TCLTLS_SSL_USE_FASTPATH - /* - * If the channel can be mapped back to a file descriptor, just use the file descriptor - * with the SSL library since it will likely be optimized for this. - */ - parentChannel = Tls_GetParent(statePtr, 0); - parentChannelType = Tcl_GetChannelType(parentChannel); - - validParentChannelFd = 0; - if (strcmp(parentChannelType->typeName, "tcp") == 0) { - tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_READABLE, (ClientData) &parentChannelFdIn_p); - if (tclGetChannelHandleRet == TCL_OK) { - tclGetChannelHandleRet = Tcl_GetChannelHandle(parentChannel, TCL_WRITABLE, (ClientData) &parentChannelFdOut_p); - if (tclGetChannelHandleRet == TCL_OK) { - parentChannelFdIn = PTR2INT(parentChannelFdIn_p); - parentChannelFdOut = PTR2INT(parentChannelFdOut_p); - if (parentChannelFdIn == parentChannelFdOut) { - parentChannelFd = parentChannelFdIn; - validParentChannelFd = 1; - } - } - } - } - - if (validParentChannelFd) { - dprintf("We found a shortcut, this channel is backed by a socket: %i", parentChannelFdIn); - bio = BIO_new_socket(parentChannelFd, flags); - statePtr->flags |= TLS_TCL_FASTPATH; - return(bio); - } - - dprintf("Falling back to Tcl I/O for this channel"); -#endif - - bio = BIO_new(BioMethods); - BIO_set_data(bio, statePtr); - BIO_set_shutdown(bio, flags); - BIO_set_init(bio, 1); - - return(bio); -} - -static int BioWrite(BIO *bio, CONST char *buf, int bufLen) { - Tcl_Channel chan; - int ret; - int tclEofChan, tclErrno; - - chan = Tls_GetParent((State *) BIO_get_data(bio), 0); - - dprintf("[chan=%p] BioWrite(%p, , %d)", (void *)chan, (void *) bio, bufLen); - - ret = Tcl_WriteRaw(chan, buf, bufLen); - - tclEofChan = Tcl_Eof(chan); - tclErrno = Tcl_GetErrno(); - - dprintf("[chan=%p] BioWrite(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, Tcl_GetErrno()); - - BIO_clear_flags(bio, BIO_FLAGS_WRITE | BIO_FLAGS_SHOULD_RETRY); - - if (tclEofChan && ret <= 0) { - dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF"); - Tcl_SetErrno(ECONNRESET); - ret = 0; - } else if (ret == 0) { - dprintf("Got 0 from Tcl_WriteRaw, and EOF is not set; ret = 0"); - dprintf("Setting retry read flag"); - BIO_set_retry_read(bio); - } else if (ret < 0) { - dprintf("We got some kind of I/O error"); - - if (tclErrno == EAGAIN) { - dprintf("It's EAGAIN"); - } else { - dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); - } - } else { - dprintf("Successfully wrote some data"); - } - - if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) { - if (BIO_should_read(bio)) { - dprintf("Setting should retry read flag"); - - BIO_set_retry_read(bio); - } - } - - return(ret); -} - -static int BioRead(BIO *bio, char *buf, int bufLen) { - Tcl_Channel chan; - int ret = 0; - int tclEofChan, tclErrno; - - chan = Tls_GetParent((State *) BIO_get_data(bio), 0); - - dprintf("[chan=%p] BioRead(%p, , %d)", (void *) chan, (void *) bio, bufLen); - - if (buf == NULL) { - return 0; - } - - ret = Tcl_ReadRaw(chan, buf, bufLen); - - tclEofChan = Tcl_Eof(chan); - tclErrno = Tcl_GetErrno(); - - dprintf("[chan=%p] BioRead(%d) -> %d [tclEof=%d; tclErrno=%d]", (void *) chan, bufLen, ret, tclEofChan, tclErrno); - - BIO_clear_flags(bio, BIO_FLAGS_READ | BIO_FLAGS_SHOULD_RETRY); - - if (tclEofChan && ret <= 0) { - dprintf("Got EOF while reading, returning a Connection Reset error which maps to Soft EOF"); - Tcl_SetErrno(ECONNRESET); - ret = 0; - } else if (ret == 0) { - dprintf("Got 0 from Tcl_Read or Tcl_ReadRaw, and EOF is not set; ret = 0"); - dprintf("Setting retry read flag"); - BIO_set_retry_read(bio); - } else if (ret < 0) { - dprintf("We got some kind of I/O error"); - - if (tclErrno == EAGAIN) { - dprintf("It's EAGAIN"); - } else { - dprintf("It's an unepxected error: %s/%i", Tcl_ErrnoMsg(tclErrno), tclErrno); - } - } else { - dprintf("Successfully read some data"); - } - - if (ret != -1 || (ret == -1 && tclErrno == EAGAIN)) { - if (BIO_should_write(bio)) { - dprintf("Setting should retry write flag"); - - BIO_set_retry_write(bio); - } - } - - dprintf("BioRead(%p, , %d) [%p] returning %i", (void *) bio, bufLen, (void *) chan, ret); - - return(ret); -} - -static int BioPuts(BIO *bio, CONST char *str) { - dprintf("BioPuts(%p, ) called", bio, str); - - return BioWrite(bio, str, (int) strlen(str)); -} - -static long BioCtrl(BIO *bio, int cmd, long num, void *ptr) { - Tcl_Channel chan; - long ret = 1; - - chan = Tls_GetParent((State *) BIO_get_data(bio), 0); - - dprintf("BioCtrl(%p, 0x%x, 0x%x, %p)", (void *) bio, (unsigned int) cmd, (unsigned int) num, (void *) ptr); - - switch (cmd) { - case BIO_CTRL_RESET: - dprintf("Got BIO_CTRL_RESET"); - num = 0; - case BIO_C_FILE_SEEK: - dprintf("Got BIO_C_FILE_SEEK"); - case BIO_C_FILE_TELL: - dprintf("Got BIO_C_FILE_TELL"); - ret = 0; - break; - case BIO_CTRL_INFO: - dprintf("Got BIO_CTRL_INFO"); - ret = 1; - break; - case BIO_C_SET_FD: - dprintf("Unsupported call: BIO_C_SET_FD"); - ret = -1; - break; - case BIO_C_GET_FD: - dprintf("Unsupported call: BIO_C_GET_FD"); - ret = -1; - break; - case BIO_CTRL_GET_CLOSE: - dprintf("Got BIO_CTRL_CLOSE"); - ret = BIO_get_shutdown(bio); - break; - case BIO_CTRL_SET_CLOSE: - dprintf("Got BIO_SET_CLOSE"); - BIO_set_shutdown(bio, num); - break; - case BIO_CTRL_EOF: - dprintf("Got BIO_CTRL_EOF"); - ret = Tcl_Eof(chan); - break; - case BIO_CTRL_PENDING: - dprintf("Got BIO_CTRL_PENDING"); - ret = ((chan) ? Tcl_InputBuffered(chan) : 0); - dprintf("BIO_CTRL_PENDING(%d)", (int) ret); - break; - case BIO_CTRL_WPENDING: - dprintf("Got BIO_CTRL_WPENDING"); - ret = 0; - break; - case BIO_CTRL_DUP: - dprintf("Got BIO_CTRL_DUP"); - break; - case BIO_CTRL_FLUSH: - dprintf("Got BIO_CTRL_FLUSH"); - ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); - dprintf("BIO_CTRL_FLUSH returning value %li", ret); - break; - default: - dprintf("Got unknown control command (%i)", cmd); - ret = -2; - break; - } - - return(ret); -} - -static int BioNew(BIO *bio) { - dprintf("BioNew(%p) called", bio); - - BIO_set_init(bio, 0); - BIO_set_data(bio, NULL); - BIO_clear_flags(bio, -1); - - return(1); -} - -static int BioFree(BIO *bio) { - if (bio == NULL) { - return(0); - } - - dprintf("BioFree(%p) called", bio); - - if (BIO_get_shutdown(bio)) { - if (BIO_get_init(bio)) { - /*shutdown(bio->num, 2) */ - /*closesocket(bio->num) */ - } - - BIO_set_init(bio, 0); - BIO_clear_flags(bio, -1); - } - - return(1); -} DELETED tlsIO.c Index: tlsIO.c ================================================================== --- tlsIO.c +++ /dev/null @@ -1,980 +0,0 @@ -/* - * Copyright (C) 1997-2000 Matt Newman - * Copyright (C) 2000 Ajuba Solutions - * - * TLS (aka SSL) Channel - can be layered on any bi-directional - * Tcl_Channel (Note: Requires Trf Core Patch) - * - * This was built from scratch based upon observation of OpenSSL 0.9.2B - * - * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for - * providing the Tcl_ReplaceChannel mechanism and working closely with me - * to enhance it to support full fileevent semantics. - * - * Also work done by the follow people provided the impetus to do this "right": - * tclSSL (Colin McCormack, Shared Technology) - * SSLtcl (Peter Antman) - * - */ - -#include "tlsInt.h" - -/* - * Forward declarations - */ -static int TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData, int mode)); -static int TlsCloseProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); -static int TlsInputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int bufSize, int *errorCodePtr)); -static int TlsOutputProc _ANSI_ARGS_((ClientData instanceData, CONST char *buf, int toWrite, int *errorCodePtr)); -static int TlsGetOptionProc _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp, CONST84 char *optionName, Tcl_DString *dsPtr)); -static void TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); -static int TlsGetHandleProc _ANSI_ARGS_((ClientData instanceData, int direction, ClientData *handlePtr)); -static int TlsNotifyProc _ANSI_ARGS_((ClientData instanceData, int mask)); -#if 0 -static void TlsChannelHandler _ANSI_ARGS_((ClientData clientData, int mask)); -#endif -static void TlsChannelHandlerTimer _ANSI_ARGS_((ClientData clientData)); - -/* - * TLS Channel Type - */ -static Tcl_ChannelType *tlsChannelType = NULL; - -/* - *------------------------------------------------------------------- - * - * Tls_ChannelType -- - * - * Return the correct TLS channel driver info - * - * Results: - * The correct channel driver for the current version of Tcl. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -Tcl_ChannelType *Tls_ChannelType(void) { - unsigned int size; - - /* - * Initialize the channel type if necessary - */ - if (tlsChannelType == NULL) { - /* - * Allocation of a new channeltype structure is not easy, because of - * the various verson of the core and subsequent changes to the - * structure. The main challenge is to allocate enough memory for - * modern versions even if this extsension is compiled against one - * of the older variant! - * - * (1) Versions before stubs (8.0.x) are simple, because they are - * supported only if the extension is compiled against exactly - * that version of the core. - * - * (2) With stubs we just determine the difference between the older - * and modern variant and overallocate accordingly if compiled - * against an older variant. - */ - size = sizeof(Tcl_ChannelType); /* Base size */ - - tlsChannelType = (Tcl_ChannelType *) ckalloc(size); - memset((VOID *) tlsChannelType, 0, size); - - /* - * Common elements of the structure (no changes in location or name) - * close2Proc, seekProc, setOptionProc stay NULL. - */ - - tlsChannelType->typeName = "tls"; - tlsChannelType->closeProc = TlsCloseProc; - tlsChannelType->inputProc = TlsInputProc; - tlsChannelType->outputProc = TlsOutputProc; - tlsChannelType->getOptionProc = TlsGetOptionProc; - tlsChannelType->watchProc = TlsWatchProc; - tlsChannelType->getHandleProc = TlsGetHandleProc; - - /* - * Compiled against 8.3.2+. Direct access to all elements possible. Use - * channelTypeVersion information to select the values to use. - */ - - /* - * For the 8.3.2 core we present ourselves as a version 2 - * driver. This means a special value in version (ex - * blockModeProc), blockModeProc in a different place and of - * course usage of the handlerProc. - */ - tlsChannelType->version = TCL_CHANNEL_VERSION_2; - tlsChannelType->blockModeProc = TlsBlockModeProc; - tlsChannelType->handlerProc = TlsNotifyProc; - } - - return(tlsChannelType); -} - -/* - *------------------------------------------------------------------- - * - * TlsBlockModeProc -- - * - * This procedure is invoked by the generic IO level - * to set blocking and nonblocking modes - * Results: - * 0 if successful, errno when failed. - * - * Side effects: - * Sets the device into blocking or nonblocking mode. - * - *------------------------------------------------------------------- - */ -static int TlsBlockModeProc(ClientData instanceData, int mode) { - State *statePtr = (State *) instanceData; - - if (mode == TCL_MODE_NONBLOCKING) { - statePtr->flags |= TLS_TCL_ASYNC; - } else { - statePtr->flags &= ~(TLS_TCL_ASYNC); - } - - return(0); -} - -/* - *------------------------------------------------------------------- - * - * TlsCloseProc -- - * - * This procedure is invoked by the generic IO level to perform - * channel-type-specific cleanup when a SSL socket based channel - * is closed. - * - * Note: we leave the underlying socket alone, is this right? - * - * Results: - * 0 if successful, the value of Tcl_GetErrno() if failed. - * - * Side effects: - * Closes the socket of the channel. - * - *------------------------------------------------------------------- - */ -static int TlsCloseProc(ClientData instanceData, Tcl_Interp *interp) { - State *statePtr = (State *) instanceData; - - dprintf("TlsCloseProc(%p)", (void *) statePtr); - - Tls_Clean(statePtr); - Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); - - dprintf("Returning TCL_OK"); - - return(TCL_OK); - - /* Interp is unused. */ - interp = interp; -} - -/* - *------------------------------------------------------* - * - * Tls_WaitForConnect -- - * - * Sideeffects: - * Issues SSL_accept or SSL_connect - * - * Result: - * None. - * - *------------------------------------------------------* - */ -int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent) { - unsigned long backingError; - int err, rc; - int bioShouldRetry; - - dprintf("WaitForConnect(%p)", (void *) statePtr); - dprintFlags(statePtr); - - if (!(statePtr->flags & TLS_TCL_INIT)) { - dprintf("Tls_WaitForConnect called on already initialized channel -- returning with immediate success"); - *errorCodePtr = 0; - return(0); - } - - if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { - /* - * Different types of operations have different requirements - * SSL being established - */ - if (handshakeFailureIsPermanent) { - dprintf("Asked to wait for a TLS handshake that has already failed. Returning fatal error"); - *errorCodePtr = ECONNABORTED; - } else { - dprintf("Asked to wait for a TLS handshake that has already failed. Returning soft error"); - *errorCodePtr = ECONNRESET; - } - return(-1); - } - - for (;;) { - /* Not initialized yet! */ - if (statePtr->flags & TLS_TCL_SERVER) { - dprintf("Calling SSL_accept()"); - - err = SSL_accept(statePtr->ssl); - } else { - dprintf("Calling SSL_connect()"); - - err = SSL_connect(statePtr->ssl); - } - - if (err > 0) { - dprintf("That seems to have gone okay"); - - err = BIO_flush(statePtr->bio); - - if (err <= 0) { - dprintf("Flushing the lower layers failed, this will probably terminate this session"); - } - } - - rc = SSL_get_error(statePtr->ssl, err); - - dprintf("Got error: %i (rc = %i)", err, rc); - - bioShouldRetry = 0; - if (err <= 0) { - if (rc == SSL_ERROR_WANT_CONNECT || rc == SSL_ERROR_WANT_ACCEPT || rc == SSL_ERROR_WANT_READ || rc == SSL_ERROR_WANT_WRITE) { - bioShouldRetry = 1; - } else if (BIO_should_retry(statePtr->bio)) { - bioShouldRetry = 1; - } else if (rc == SSL_ERROR_SYSCALL && Tcl_GetErrno() == EAGAIN) { - bioShouldRetry = 1; - } - } else { - if (!SSL_is_init_finished(statePtr->ssl)) { - bioShouldRetry = 1; - } - } - - if (bioShouldRetry) { - dprintf("The I/O did not complete -- but we should try it again"); - - if (statePtr->flags & TLS_TCL_ASYNC) { - dprintf("Returning EAGAIN so that it can be retried later"); - - *errorCodePtr = EAGAIN; - - return(-1); - } else { - dprintf("Doing so now"); - - continue; - } - } - - dprintf("We have either completely established the session or completely failed it -- there is no more need to ever retry it though"); - break; - } - - - *errorCodePtr = EINVAL; - - switch (rc) { - case SSL_ERROR_NONE: - /* The connection is up, we are done here */ - dprintf("The connection is up"); - break; - case SSL_ERROR_ZERO_RETURN: - dprintf("SSL_ERROR_ZERO_RETURN: Connect returned an invalid value...") - return(-1); - case SSL_ERROR_SYSCALL: - backingError = ERR_get_error(); - - if (backingError == 0 && err == 0) { - dprintf("EOF reached") - *errorCodePtr = ECONNRESET; - } else if (backingError == 0 && err == -1) { - dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); - *errorCodePtr = Tcl_GetErrno(); - if (*errorCodePtr == ECONNRESET) { - *errorCodePtr = ECONNABORTED; - } - } else { - dprintf("I/O error occured (backingError = %lu)", backingError); - *errorCodePtr = backingError; - if (*errorCodePtr == ECONNRESET) { - *errorCodePtr = ECONNABORTED; - } - } - - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; - - return(-1); - case SSL_ERROR_SSL: - dprintf("Got permanent fatal SSL error, aborting immediately"); - Tls_Error(statePtr, (char *)ERR_reason_error_string(ERR_get_error())); - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; - *errorCodePtr = ECONNABORTED; - return(-1); - case SSL_ERROR_WANT_CONNECT: - case SSL_ERROR_WANT_ACCEPT: - case SSL_ERROR_WANT_X509_LOOKUP: - default: - dprintf("We got a confusing reply: %i", rc); - *errorCodePtr = Tcl_GetErrno(); - dprintf("ERR(%d, %d) ", rc, *errorCodePtr); - return(-1); - } - -#if 0 - if (statePtr->flags & TLS_TCL_SERVER) { - dprintf("This is an TLS server, checking the certificate for the peer"); - - err = SSL_get_verify_result(statePtr->ssl); - if (err != X509_V_OK) { - dprintf("Invalid certificate, returning in failure"); - - Tls_Error(statePtr, (char *)X509_verify_cert_error_string(err)); - statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED; - *errorCodePtr = ECONNABORTED; - return(-1); - } - } -#endif - - dprintf("Removing the \"TLS_TCL_INIT\" flag since we have completed the handshake"); - statePtr->flags &= ~TLS_TCL_INIT; - - dprintf("Returning in success"); - *errorCodePtr = 0; - - return(0); -} - -/* - *------------------------------------------------------------------- - * - * TlsInputProc -- - * - * This procedure is invoked by the generic IO level - * to read input from a SSL socket based channel. - * - * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no - * error occurred. - * - * Side effects: - * Reads input from the input device of the channel. - * - *------------------------------------------------------------------- - */ - -static int TlsInputProc(ClientData instanceData, char *buf, int bufSize, int *errorCodePtr) { - unsigned long backingError; - State *statePtr = (State *) instanceData; - int bytesRead; - int tlsConnect; - int err; - - *errorCodePtr = 0; - - dprintf("BIO_read(%d)", bufSize); - - if (statePtr->flags & TLS_TCL_CALLBACK) { - /* don't process any bytes while verify callback is running */ - dprintf("Callback is running, reading 0 bytes"); - return(0); - } - - dprintf("Calling Tls_WaitForConnect"); - tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 0); - if (tlsConnect < 0) { - dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr); - - bytesRead = -1; - if (*errorCodePtr == ECONNRESET) { - dprintf("Got connection reset"); - /* Soft EOF */ - *errorCodePtr = 0; - bytesRead = 0; - } - - return(bytesRead); - } - - /* - * We need to clear the SSL error stack now because we sometimes reach - * this function with leftover errors in the stack. If BIO_read - * returns -1 and intends EAGAIN, there is a leftover error, it will be - * misconstrued as an error, not EAGAIN. - * - * Alternatively, we may want to handle the <0 return codes from - * BIO_read specially (as advised in the RSA docs). TLS's lower level BIO - * functions play with the retry flags though, and this seems to work - * correctly. Similar fix in TlsOutputProc. - hobbs - */ - ERR_clear_error(); - bytesRead = BIO_read(statePtr->bio, buf, bufSize); - dprintf("BIO_read -> %d", bytesRead); - - err = SSL_get_error(statePtr->ssl, bytesRead); - -#if 0 - if (bytesRead <= 0) { - if (BIO_should_retry(statePtr->bio)) { - dprintf("I/O failed, will retry based on EAGAIN"); - *errorCodePtr = EAGAIN; - } - } -#endif - - switch (err) { - case SSL_ERROR_NONE: - dprintBuffer(buf, bytesRead); - break; - case SSL_ERROR_SSL: - dprintf("SSL negotiation error, indicating that the connection has been aborted"); - - Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, bytesRead)); - *errorCodePtr = ECONNABORTED; - bytesRead = -1; - - break; - case SSL_ERROR_SYSCALL: - backingError = ERR_get_error(); - - if (backingError == 0 && bytesRead == 0) { - dprintf("EOF reached") - *errorCodePtr = 0; - bytesRead = 0; - } else if (backingError == 0 && bytesRead == -1) { - dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - } else { - dprintf("I/O error occured (backingError = %lu)", backingError); - *errorCodePtr = backingError; - bytesRead = -1; - } - - break; - case SSL_ERROR_ZERO_RETURN: - dprintf("Got SSL_ERROR_ZERO_RETURN, this means an EOF has been reached"); - bytesRead = 0; - *errorCodePtr = 0; - break; - case SSL_ERROR_WANT_READ: - dprintf("Got SSL_ERROR_WANT_READ, mapping this to EAGAIN"); - bytesRead = -1; - *errorCodePtr = EAGAIN; - break; - default: - dprintf("Unknown error (err = %i), mapping to EOF", err); - *errorCodePtr = 0; - bytesRead = 0; - break; - } - - dprintf("Input(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr); - return(bytesRead); -} - -/* - *------------------------------------------------------------------- - * - * TlsOutputProc -- - * - * This procedure is invoked by the generic IO level - * to write output to a SSL socket based channel. - * - * Results: - * The number of bytes written is returned. An output argument is - * set to a POSIX error code if an error occurred, or zero. - * - * Side effects: - * Writes output on the output device of the channel. - * - *------------------------------------------------------------------- - */ - -static int TlsOutputProc(ClientData instanceData, CONST char *buf, int toWrite, int *errorCodePtr) { - unsigned long backingError; - State *statePtr = (State *) instanceData; - int written, err; - int tlsConnect; - - *errorCodePtr = 0; - - dprintf("BIO_write(%p, %d)", (void *) statePtr, toWrite); - dprintBuffer(buf, toWrite); - - if (statePtr->flags & TLS_TCL_CALLBACK) { - dprintf("Don't process output while callbacks are running") - written = -1; - *errorCodePtr = EAGAIN; - return(-1); - } - - dprintf("Calling Tls_WaitForConnect"); - tlsConnect = Tls_WaitForConnect(statePtr, errorCodePtr, 1); - if (tlsConnect < 0) { - dprintf("Got an error waiting to connect (tlsConnect = %i, *errorCodePtr = %i)", tlsConnect, *errorCodePtr); - - written = -1; - if (*errorCodePtr == ECONNRESET) { - dprintf("Got connection reset"); - /* Soft EOF */ - *errorCodePtr = 0; - written = 0; - } - - return(written); - } - - if (toWrite == 0) { - dprintf("zero-write"); - err = BIO_flush(statePtr->bio); - - if (err <= 0) { - dprintf("Flushing failed"); - - *errorCodePtr = EIO; - written = 0; - return(-1); - } - - written = 0; - *errorCodePtr = 0; - return(0); - } - - /* - * We need to clear the SSL error stack now because we sometimes reach - * this function with leftover errors in the stack. If BIO_write - * returns -1 and intends EAGAIN, there is a leftover error, it will be - * misconstrued as an error, not EAGAIN. - * - * Alternatively, we may want to handle the <0 return codes from - * BIO_write specially (as advised in the RSA docs). TLS's lower level - * BIO functions play with the retry flags though, and this seems to - * work correctly. Similar fix in TlsInputProc. - hobbs - */ - ERR_clear_error(); - written = BIO_write(statePtr->bio, buf, toWrite); - dprintf("BIO_write(%p, %d) -> [%d]", (void *) statePtr, toWrite, written); - - err = SSL_get_error(statePtr->ssl, written); - switch (err) { - case SSL_ERROR_NONE: - if (written < 0) { - written = 0; - } - break; - case SSL_ERROR_WANT_WRITE: - dprintf("Got SSL_ERROR_WANT_WRITE, mapping it to EAGAIN"); - *errorCodePtr = EAGAIN; - written = -1; - break; - case SSL_ERROR_WANT_READ: - dprintf(" write R BLOCK"); - break; - case SSL_ERROR_WANT_X509_LOOKUP: - dprintf(" write X BLOCK"); - break; - case SSL_ERROR_ZERO_RETURN: - dprintf(" closed"); - written = 0; - *errorCodePtr = 0; - break; - case SSL_ERROR_SYSCALL: - backingError = ERR_get_error(); - - if (backingError == 0 && written == 0) { - dprintf("EOF reached") - *errorCodePtr = 0; - written = 0; - } else if (backingError == 0 && written == -1) { - dprintf("I/O error occured (errno = %lu)", (unsigned long) Tcl_GetErrno()); - *errorCodePtr = Tcl_GetErrno(); - written = -1; - } else { - dprintf("I/O error occured (backingError = %lu)", backingError); - *errorCodePtr = backingError; - written = -1; - } - - break; - case SSL_ERROR_SSL: - Tls_Error(statePtr, TCLTLS_SSL_ERROR(statePtr->ssl, written)); - *errorCodePtr = ECONNABORTED; - written = -1; - break; - default: - dprintf(" unknown err: %d", err); - break; - } - - dprintf("Output(%d) -> %d", toWrite, written); - return(written); -} - -/* - *------------------------------------------------------------------- - * - * TlsGetOptionProc -- - * - * Computes an option value for a SSL socket based channel, or a - * list of all options and their values. - * - * 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. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -static int -TlsGetOptionProc(ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For errors - can be NULL. */ - CONST84 char *optionName, /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr) /* Where to store the computed value - * initialized by caller. */ -{ - State *statePtr = (State *) instanceData; - - Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); - Tcl_DriverGetOptionProc *getOptionProc; - - getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); - if (getOptionProc != NULL) { - return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr); - } else if (optionName == (char*) NULL) { - /* - * Request is query for all options, this is ok. - */ - return TCL_OK; - } - /* - * Request for a specific option has to fail, we don't have any. - */ - return TCL_ERROR; -} - -/* - *------------------------------------------------------------------- - * - * TlsWatchProc -- - * - * Initialize the notifier to watch Tcl_Files 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 -TlsWatchProc(ClientData instanceData, /* The socket state. */ - int mask) /* Events of interest; an OR-ed - * combination of TCL_READABLE, - * TCL_WRITABLE and TCL_EXCEPTION. */ -{ - Tcl_Channel downChan; - State *statePtr = (State *) instanceData; - - dprintf("TlsWatchProc(0x%x)", mask); - - /* Pretend to be dead as long as the verify callback is running. - * Otherwise that callback could be invoked recursively. */ - if (statePtr->flags & TLS_TCL_CALLBACK) { - dprintf("Callback is on-going, doing nothing"); - return; - } - - dprintFlags(statePtr); - - downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH); - - if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) { - dprintf("Asked to watch a socket with a failed handshake -- nothing can happen here"); - - dprintf("Unregistering interest in the lower channel"); - (Tcl_GetChannelType(downChan))->watchProc(Tcl_GetChannelInstanceData(downChan), 0); - - statePtr->watchMask = 0; - - return; - } - - statePtr->watchMask = mask; - - /* No channel handlers any more. We will be notified automatically - * about events on the channel below via a call to our - * 'TransformNotifyProc'. But we have to pass the interest down now. - * We are allowed to add additional 'interest' to the mask if we want - * to. But this transformation has no such interest. It just passes - * the request down, unchanged. - */ - - - dprintf("Registering our interest in the lower channel (chan=%p)", (void *) downChan); - (Tcl_GetChannelType(downChan)) - ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); - - /* - * Management of the internal timer. - */ - - if (statePtr->timer != (Tcl_TimerToken) NULL) { - dprintf("A timer was found, deleting it"); - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken) NULL; - } - - if (mask & TCL_READABLE) { - if (Tcl_InputBuffered(statePtr->self) > 0 || BIO_ctrl_pending(statePtr->bio) > 0) { - /* - * There is interest in readable events and we actually have - * data waiting, so generate a timer to flush that. - */ - dprintf("Creating a new timer since data appears to be waiting"); - statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); - } - } -} - -/* - *------------------------------------------------------------------- - * - * TlsGetHandleProc -- - * - * Called from Tcl_GetChannelFile to retrieve o/s file handler - * from the SSL socket based channel. - * - * Results: - * The appropriate Tcl_File or NULL if not present. - * - * Side effects: - * None. - * - *------------------------------------------------------------------- - */ -static int TlsGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr) { - State *statePtr = (State *) instanceData; - - return(Tcl_GetChannelHandle(Tls_GetParent(statePtr, TLS_TCL_FASTPATH), direction, handlePtr)); -} - -/* - *------------------------------------------------------------------- - * - * TlsNotifyProc -- - * - * Handler called by Tcl to inform us of activity - * on the underlying channel. - * - * Results: - * None. - * - * Side effects: - * May process the incoming event by itself. - * - *------------------------------------------------------------------- - */ - -static int TlsNotifyProc(ClientData instanceData, int mask) { - State *statePtr = (State *) instanceData; - int errorCode; - - /* - * An event occured in the underlying channel. This - * transformation doesn't process such events thus returns the - * incoming mask unchanged. - */ - if (statePtr->timer != (Tcl_TimerToken) NULL) { - /* - * Delete an existing timer. It was not fired, yet we are - * here, so the channel below generated such an event and we - * don't have to. The renewal of the interest after the - * execution of channel handlers will eventually cause us to - * recreate the timer (in WatchProc). - */ - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken) NULL; - } - - if (statePtr->flags & TLS_TCL_CALLBACK) { - dprintf("Returning 0 due to callback"); - return 0; - } - - dprintf("Calling Tls_WaitForConnect"); - errorCode = 0; - if (Tls_WaitForConnect(statePtr, &errorCode, 1) < 0) { - if (errorCode == EAGAIN) { - dprintf("Async flag could be set (didn't check) and errorCode == EAGAIN: Returning 0"); - - return 0; - } - - dprintf("Tls_WaitForConnect returned an error"); - } - - dprintf("Returning %i", mask); - - return(mask); -} - -#if 0 -/* - *------------------------------------------------------* - * - * TlsChannelHandler -- - * - * ------------------------------------------------* - * Handler called by Tcl as a result of - * Tcl_CreateChannelHandler - to inform us of activity - * on the underlying channel. - * ------------------------------------------------* - * - * Sideeffects: - * May generate subsequent calls to - * Tcl_NotifyChannel. - * - * Result: - * None. - * - *------------------------------------------------------* - */ - -static void -TlsChannelHandler (clientData, mask) - ClientData clientData; - int mask; -{ - State *statePtr = (State *) clientData; - - dprintf("HANDLER(0x%x)", mask); - Tcl_Preserve( (ClientData)statePtr); - - if (mask & TCL_READABLE) { - BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ); - } else { - BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ); - } - - if (mask & TCL_WRITABLE) { - BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE); - } else { - BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE); - } - - mask = 0; - if (BIO_wpending(statePtr->bio)) { - mask |= TCL_WRITABLE; - } - if (BIO_pending(statePtr->bio)) { - mask |= TCL_READABLE; - } - - /* - * The following NotifyChannel calls seems to be important, but - * we don't know why. It looks like if the mask is ever non-zero - * that it will enter an infinite loop. - * - * Notify the upper channel of the current BIO state so the event - * continues to propagate up the chain. - * - * stanton: It looks like this could result in an infinite loop if - * the upper channel doesn't cause ChannelHandler to be removed - * before Tcl_NotifyChannel calls channel handlers on the lower channel. - */ - - Tcl_NotifyChannel(statePtr->self, mask); - - if (statePtr->timer != (Tcl_TimerToken)NULL) { - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken)NULL; - } - if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { - /* - * Data is waiting, flush it out in short time - */ - statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, - TlsChannelHandlerTimer, (ClientData) statePtr); - } - Tcl_Release( (ClientData)statePtr); -} -#endif - -/* - *------------------------------------------------------* - * - * TlsChannelHandlerTimer -- - * - * ------------------------------------------------* - * Called by the notifier (-> timer) to flush out - * information waiting in channel buffers. - * ------------------------------------------------* - * - * Sideeffects: - * As of 'TlsChannelHandler'. - * - * Result: - * None. - * - *------------------------------------------------------* - */ - -static void TlsChannelHandlerTimer(ClientData clientData) { - State *statePtr = (State *) clientData; - int mask = 0; - - dprintf("Called"); - - statePtr->timer = (Tcl_TimerToken) NULL; - - if (BIO_wpending(statePtr->bio)) { - dprintf("[chan=%p] BIO writable", statePtr->self); - - mask |= TCL_WRITABLE; - } - - if (BIO_pending(statePtr->bio)) { - dprintf("[chan=%p] BIO readable", statePtr->self); - - mask |= TCL_READABLE; - } - - dprintf("Notifying ourselves"); - Tcl_NotifyChannel(statePtr->self, mask); - - dprintf("Returning"); - - return; -} - -Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags) { - dprintf("Requested to get parent of channel %p", statePtr->self); - - if ((statePtr->flags & ~maskFlags) & TLS_TCL_FASTPATH) { - dprintf("Asked to get the parent channel while we are using FastPath -- returning NULL"); - return(NULL); - } - - return(Tcl_GetStackedChannel(statePtr->self)); -} DELETED tlsInt.h Index: tlsInt.h ================================================================== --- tlsInt.h +++ /dev/null @@ -1,180 +0,0 @@ -/* - * Copyright (C) 1997-2000 Matt Newman - * - * TLS (aka SSL) Channel - can be layered on any bi-directional - * Tcl_Channel (Note: Requires Trf Core Patch) - * - * This was built from scratch based upon observation of OpenSSL 0.9.2B - * - * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for - * providing the Tcl_ReplaceChannel mechanism and working closely with me - * to enhance it to support full fileevent semantics. - * - * Also work done by the follow people provided the impetus to do this "right":- - * tclSSL (Colin McCormack, Shared Technology) - * SSLtcl (Peter Antman) - * - */ -#ifndef _TLSINT_H -#define _TLSINT_H - -#include "tls.h" -#include -#include -#include - -#ifdef __WIN32__ -#define WIN32_LEAN_AND_MEAN -#include -#include /* OpenSSL needs this on Windows */ -#endif - -/* Handle tcl8.3->tcl8.4 CONST changes */ -#ifndef CONST84 -#define CONST84 -#endif - -#ifdef NO_PATENTS -# define NO_IDEA -# define NO_RC2 -# define NO_RC4 -# define NO_RC5 -# define NO_RSA -# ifndef NO_SSL2 -# define NO_SSL2 -# endif -#endif - -#include -#include -#include -#include - -/* - * Determine if we should use the pre-OpenSSL 1.1.0 API - */ -#undef TCLTLS_OPENSSL_PRE_1_1 -#if (defined(LIBRESSL_VERSION_NUMBER)) || OPENSSL_VERSION_NUMBER < 0x10100000L -# define TCLTLS_OPENSSL_PRE_1_1_API 1 -#endif - -#ifndef ECONNABORTED -#define ECONNABORTED 130 /* Software caused connection abort */ -#endif -#ifndef ECONNRESET -#define ECONNRESET 131 /* Connection reset by peer */ -#endif - -#ifdef TCLEXT_TCLTLS_DEBUG -#include -#define dprintf(...) { \ - char dprintfBuffer[8192], *dprintfBuffer_p; \ - dprintfBuffer_p = &dprintfBuffer[0]; \ - dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():", __FILE__, __LINE__, __func__); \ - dprintfBuffer_p += sprintf(dprintfBuffer_p, __VA_ARGS__); \ - fprintf(stderr, "%s\n", dprintfBuffer); \ - } -#define dprintBuffer(bufferName, bufferLength) { \ - int dprintBufferIdx; \ - unsigned char dprintBufferChar; \ - fprintf(stderr, "%s:%i:%s():%s[%llu]={", __FILE__, __LINE__, __func__, #bufferName, (unsigned long long) bufferLength); \ - for (dprintBufferIdx = 0; dprintBufferIdx < bufferLength; dprintBufferIdx++) { \ - dprintBufferChar = bufferName[dprintBufferIdx]; \ - if (isalpha(dprintBufferChar) || isdigit(dprintBufferChar)) { \ - fprintf(stderr, "'%c' ", dprintBufferChar); \ - } else { \ - fprintf(stderr, "%02x ", (unsigned int) dprintBufferChar); \ - }; \ - }; \ - fprintf(stderr, "}\n"); \ - } -#define dprintFlags(statePtr) { \ - char dprintfBuffer[8192], *dprintfBuffer_p; \ - dprintfBuffer_p = &dprintfBuffer[0]; \ - dprintfBuffer_p += sprintf(dprintfBuffer_p, "%s:%i:%s():%s->flags=0", __FILE__, __LINE__, __func__, #statePtr); \ - if (((statePtr)->flags & TLS_TCL_ASYNC) == TLS_TCL_ASYNC) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_ASYNC"); }; \ - if (((statePtr)->flags & TLS_TCL_SERVER) == TLS_TCL_SERVER) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_SERVER"); }; \ - if (((statePtr)->flags & TLS_TCL_INIT) == TLS_TCL_INIT) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_INIT"); }; \ - if (((statePtr)->flags & TLS_TCL_DEBUG) == TLS_TCL_DEBUG) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_DEBUG"); }; \ - if (((statePtr)->flags & TLS_TCL_CALLBACK) == TLS_TCL_CALLBACK) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_CALLBACK"); }; \ - if (((statePtr)->flags & TLS_TCL_HANDSHAKE_FAILED) == TLS_TCL_HANDSHAKE_FAILED) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_HANDSHAKE_FAILED"); }; \ - if (((statePtr)->flags & TLS_TCL_FASTPATH) == TLS_TCL_FASTPATH) { dprintfBuffer_p += sprintf(dprintfBuffer_p, "|TLS_TCL_FASTPATH"); }; \ - fprintf(stderr, "%s\n", dprintfBuffer); \ - } -#else -#define dprintf(...) if (0) { fprintf(stderr, __VA_ARGS__); } -#define dprintBuffer(bufferName, bufferLength) /**/ -#define dprintFlags(statePtr) /**/ -#endif - -#define TCLTLS_SSL_ERROR(ssl,err) ((char*)ERR_reason_error_string((unsigned long)SSL_get_error((ssl),(err)))) -/* - * OpenSSL BIO Routines - */ -#define BIO_TYPE_TCL (19|0x0400) - -/* - * Defines for State.flags - */ -#define TLS_TCL_ASYNC (1<<0) /* non-blocking mode */ -#define TLS_TCL_SERVER (1<<1) /* Server-Side */ -#define TLS_TCL_INIT (1<<2) /* Initializing connection */ -#define TLS_TCL_DEBUG (1<<3) /* Show debug tracing */ -#define TLS_TCL_CALLBACK (1<<4) /* In a callback, prevent update - * looping problem. [Bug 1652380] */ -#define TLS_TCL_HANDSHAKE_FAILED (1<<5) /* Set on handshake failures and once - * set, all further I/O will result - * in ECONNABORTED errors. */ -#define TLS_TCL_FASTPATH (1<<6) /* The parent channel is being used directly by the SSL library */ -#define TLS_TCL_DELAY (5) - -/* - * This structure describes the per-instance state - * of an ssl channel. - * - * The SSL processing context is maintained here, in the ClientData - */ -typedef struct State { - Tcl_Channel self; /* this socket channel */ - Tcl_TimerToken timer; - - int flags; /* see State.flags above */ - int watchMask; /* current WatchProc mask */ - int mode; /* current mode of parent channel */ - - Tcl_Interp *interp; /* interpreter in which this resides */ - Tcl_Obj *callback; /* script called for tracing, verifying and errors */ - Tcl_Obj *password; /* script called for certificate password */ - - int vflags; /* verify flags */ - SSL *ssl; /* Struct for SSL processing */ - SSL_CTX *ctx; /* SSL Context */ - BIO *bio; /* Struct for SSL processing */ - BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */ - - char *err; -} State; - -#ifdef USE_TCL_STUBS -#ifndef Tcl_StackChannel -#error "Unable to compile on this version of Tcl" -#endif /* Tcl_GetStackedChannel */ -#endif /* USE_TCL_STUBS */ - -/* - * Forward declarations - */ -Tcl_ChannelType *Tls_ChannelType(void); -Tcl_Channel Tls_GetParent(State *statePtr, int maskFlags); - -Tcl_Obj *Tls_NewX509Obj(Tcl_Interp *interp, X509 *cert); -void Tls_Error(State *statePtr, char *msg); -void Tls_Free(char *blockPtr); -void Tls_Clean(State *statePtr); -int Tls_WaitForConnect(State *statePtr, int *errorCodePtr, int handshakeFailureIsPermanent); - -BIO *BIO_new_tcl(State* statePtr, int flags); - -#define PTR2INT(x) ((int) ((intptr_t) (x))) - -#endif /* _TLSINT_H */ DELETED tlsX509.c Index: tlsX509.c ================================================================== --- tlsX509.c +++ /dev/null @@ -1,209 +0,0 @@ -/* - * Copyright (C) 1997-2000 Sensus Consulting Ltd. - * Matt Newman - */ -#include "tlsInt.h" - -/* - * Ensure these are not macros - known to be defined on Win32 - */ -#ifdef min -#undef min -#endif - -#ifdef max -#undef max -#endif - -static int min(int a, int b) -{ - return (a < b) ? a : b; -} - -static int max(int a, int b) -{ - return (a > b) ? a : b; -} - -/* - * ASN1_UTCTIME_tostr -- - */ -static char * -ASN1_UTCTIME_tostr(ASN1_UTCTIME *tm) -{ - static char bp[128]; - char *v; - int gmt=0; - static char *mon[12]={ - "Jan","Feb","Mar","Apr","May","Jun", - "Jul","Aug","Sep","Oct","Nov","Dec"}; - int i; - int y=0,M=0,d=0,h=0,m=0,s=0; - - i=tm->length; - v=(char *)tm->data; - - if (i < 10) goto err; - if (v[i-1] == 'Z') gmt=1; - for (i=0; i<10; i++) - if ((v[i] > '9') || (v[i] < '0')) goto err; - y= (v[0]-'0')*10+(v[1]-'0'); - if (y < 70) y+=100; - M= (v[2]-'0')*10+(v[3]-'0'); - if ((M > 12) || (M < 1)) goto err; - d= (v[4]-'0')*10+(v[5]-'0'); - h= (v[6]-'0')*10+(v[7]-'0'); - m= (v[8]-'0')*10+(v[9]-'0'); - if ( (v[10] >= '0') && (v[10] <= '9') && - (v[11] >= '0') && (v[11] <= '9')) - s= (v[10]-'0')*10+(v[11]-'0'); - - sprintf(bp,"%s %2d %02d:%02d:%02d %d%s", - mon[M-1],d,h,m,s,y+1900,(gmt)?" GMT":""); - return bp; - err: - return "Bad time value"; -} - -/* - *------------------------------------------------------* - * - * Tls_NewX509Obj -- - * - * ------------------------------------------------* - * Converts a X509 certificate into a Tcl_Obj - * ------------------------------------------------* - * - * Sideeffects: - * None - * - * Result: - * A Tcl List Object representing the provided - * X509 certificate. - * - *------------------------------------------------------* - */ - -#define CERT_STR_SIZE 16384 - -Tcl_Obj* -Tls_NewX509Obj( interp, cert) - Tcl_Interp *interp; - X509 *cert; -{ - Tcl_Obj *certPtr = Tcl_NewListObj( 0, NULL); - BIO *bio; - int n; - unsigned long flags; - char subject[BUFSIZ]; - char issuer[BUFSIZ]; - char serial[BUFSIZ]; - char notBefore[BUFSIZ]; - char notAfter[BUFSIZ]; - char certStr[CERT_STR_SIZE], *certStr_p; - int certStr_len, toRead; -#ifndef NO_SSL_SHA - int shai; - char sha_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1]; - unsigned char sha_hash_binary[SHA_DIGEST_LENGTH]; - const char *shachars="0123456789ABCDEF"; - - sha_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0'; -#endif - - certStr[0] = 0; - if ((bio = BIO_new(BIO_s_mem())) == NULL) { - subject[0] = 0; - issuer[0] = 0; - serial[0] = 0; - } else { - flags = XN_FLAG_RFC2253 | ASN1_STRFLGS_UTF8_CONVERT; - flags &= ~ASN1_STRFLGS_ESC_MSB; - - X509_NAME_print_ex(bio, X509_get_subject_name(cert), 0, flags); - n = BIO_read(bio, subject, min(BIO_pending(bio), BUFSIZ - 1)); - n = max(n, 0); - subject[n] = 0; - (void)BIO_flush(bio); - - X509_NAME_print_ex(bio, X509_get_issuer_name(cert), 0, flags); - n = BIO_read(bio, issuer, min(BIO_pending(bio), BUFSIZ - 1)); - n = max(n, 0); - issuer[n] = 0; - (void)BIO_flush(bio); - - i2a_ASN1_INTEGER(bio, X509_get_serialNumber(cert)); - n = BIO_read(bio, serial, min(BIO_pending(bio), BUFSIZ - 1)); - n = max(n, 0); - serial[n] = 0; - (void)BIO_flush(bio); - - if (PEM_write_bio_X509(bio, cert)) { - certStr_p = certStr; - certStr_len = 0; - while (1) { - toRead = min(BIO_pending(bio), CERT_STR_SIZE - certStr_len - 1); - toRead = min(toRead, BUFSIZ); - if (toRead == 0) { - break; - } - dprintf("Reading %i bytes from the certificate...", toRead); - n = BIO_read(bio, certStr_p, toRead); - if (n <= 0) { - break; - } - certStr_len += n; - certStr_p += n; - } - *certStr_p = '\0'; - (void)BIO_flush(bio); - } - - BIO_free(bio); - } - - strcpy( notBefore, ASN1_UTCTIME_tostr( X509_get_notBefore(cert) )); - strcpy( notAfter, ASN1_UTCTIME_tostr( X509_get_notAfter(cert) )); - -#ifndef NO_SSL_SHA - X509_digest(cert, EVP_sha1(), sha_hash_binary, NULL); - for (shai = 0; shai < SHA_DIGEST_LENGTH; shai++) { - sha_hash_ascii[shai * 2] = shachars[(sha_hash_binary[shai] & 0xF0) >> 4]; - sha_hash_ascii[shai * 2 + 1] = shachars[(sha_hash_binary[shai] & 0x0F)]; - } - Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha_hash_ascii, SHA_DIGEST_LENGTH * 2) ); - -#endif - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "subject", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( subject, -1) ); - - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "issuer", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( issuer, -1) ); - - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "notBefore", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( notBefore, -1) ); - - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "notAfter", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( notAfter, -1) ); - - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "serial", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( serial, -1) ); - - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( "certificate", -1) ); - Tcl_ListObjAppendElement( interp, certPtr, - Tcl_NewStringObj( certStr, -1) ); - - return certPtr; -} Index: win/README.txt ================================================================== --- win/README.txt +++ win/README.txt @@ -1,64 +1,49 @@ - Windows DLL Build instructions using nmake build system - 2020-10-15 Harald.Oehlmann@elmicron.de - -Properties: -- 32 bit DLL -- VisualStudio 2015 -Note: Vuisual C++ 6 does not build OpenSSL (long long syntax error) -- Cygwin32 (temporary helper, please help to replace by tclsh) -- OpenSSL statically linked to TCLTLS DLL. -Note: Dynamic linking also works but results in a DLL dependeny on OPENSSL DLL's - -1) Build OpenSSL static libraries: - -OpenSSL source distribtution unpacked in: -c:\test\tcltls\Openssl_1_1_1h - -- Install Perl from http://strawberryperl.com/download/5.32.0.1/strawberry-perl-5.32.0.1-32bit.msi - to C:\perl - (ActivePerl failed due to missing 32 bit console module) -- Install NASM Assembler: - -https://www.nasm.us/pub/nasm/releasebuilds/2.15.05/win32/nasm-2.15.05-installer-x86.exe - to C:\Program Files (x86)\NASM - --> Visual Studio x86 native prompt. - -set Path=%PATH%;C:\Program Files (x86)\NASM;C:\Perl\perl\bin - -perl Configure VC-WIN32 --prefix=c:\test\tcltls\openssl --openssldir=c:\test\tcltls\openssldir no-shared no-filenames threads - -nmake -nmake test -namke install - -2) Build TCLTLS - -Unzip distribution in: -c:\test\tcltls\tcltls-1.7.22 - --> start cygwin bash prompt - -cd /cygdrive/c/test/tcltls/tcltls-1.7.22 -./gen_dh_params > dh_params.h - -od -A n -v -t xC < 'tls.tcl' > tls.tcl.h.new.1 -sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > tls.tcl.h -rm -f tls.tcl.h.new.1 - --> Visual Studio x86 native prompt. - -cd C:\test\tcltls\tcltls-1.7.22\win - -nmake -f makefile.vc TCLDIR=c:\test\tcl8610 SSL_INSTALL_FOLDER=C:\test\tcltls\openssl - -nmake -f makefile.vc install TCLDIR=c:\test\tcl8610 INSTALLDIR=c:\test\tcltls SSL_INSTALL_FOLDER=C:\test\tcltls\openssl - -3) Test - -Start tclsh or wish - -lappend auto_path {C:\test\tcltls\tls1.7.22} -package require tls - -A small "1.7.22" showing up is hopefully the end of this long way... + Windows DLL Build instructions using nmake build system + 2020-10-15 Harald.Oehlmann@elmicron.de + 2023-08-22 Kevin Walzer (kw@codebykevin.com) + +Properties: +- 64 bit DLL +- VisualStudio 2019 +- WSL +- OpenSSL dynamically linked to TCLTLS DLL. We used a freely redistributable build of OpenSSL from https://www.firedaemon.com/firedaemon-openssl. Unzip and install OpenSSL in an accessible place (we used the lib subdirectory of our Tcl installation). + +1. Visual Studio x86 native prompt. Update environmental variables for building Tcltls. Customize the below entries for your setup. + +set PATH=%PATH%;C:\tcl-trunk\lib\openssl-3\x64\bin +set INCLUDE=%INCLUDE%;C:\tcl-trunk\tcl\lib\openssl-3\x64\include\openssl +set LIB=%LIB%;C:\tcl-trunk\tcl\lib\openssl-3\x64\bin + + +2) Build TCLTLS + +-> Unzip distribution on your system. +-> Start WSL. +-> cd /mnt/c/path/to/tcltls + +./gen_dh_params > dh_params.h + +od -A n -v -t xC < 'tls.tcl' > tls.tcl.h.new.1 +sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > tls.tcl.h +rm -f tls.tcl.h.new.1 + +-> Visual Studio x86 native prompt. + +cd C:path\to\tcltls\win + +Run the following commands (modify the flags to your specific installations). + +nmake -f makefile.vc TCLDIR=c:\users\wordt\tcl INSTALLDIR=c:\tcl-trunk\tcl\lib SSL_INSTALL_FOLDER=C:\tcl-trunk\tcl\lib\openssl-3\x64 + +nmake -f makefile.vc TCLDIR=c:\users\wordt\tcl INSTALLDIR=c:\tcl-trunk\tcl\lib SSL_INSTALL_FOLDER=C:\tcl-trunk\tcl\lib\openssl-3\x64 install + +The resulting installation will include both the tcltls package and also have libcrypto.dll and libssl.dll copied into the same directory. + +3) Test + +Start tclsh + +package require tls +package require http +http::register https 443 [list ::tls::socket -autoservername true] +set tok [http::data [http::geturl https://www.tcl-lang.org]] ADDED win/gitmanifest.in Index: win/gitmanifest.in ================================================================== --- /dev/null +++ win/gitmanifest.in @@ -0,0 +1,1 @@ +git- Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -1,24 +1,70 @@ -# call nmake with additional parameter SSL_INSTALL_FOLDER= with the -# OpenSSL instalation folder following. +#------------------------------------------------------------- -*- makefile -*- +# +# Makefile for TclTLS extensions. +# +# Basic build, test and install +# nmake /f makefile.vc INSTALLDIR=c:\path\to\tcl +# nmake /f makefile.vc INSTALLDIR=c:\path\to\tcl test +# nmake /f makefile.vc INSTALLDIR=c:\path\to\tcl install +# +# For other build options (debug, static etc.), +# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for +# detailed documentation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +#------------------------------------------------------------------------------ +# The name of the package PROJECT=tls -DOTVERSION = 1.7.22 + +!include "rules-ext.vc" + +# Define the object files and resource file that make up the extension. +# Note the resource file does not makes sense if doing a static library build +# hence it is under that condition. TMP_DIR is the output directory +# defined by rules for object files. +PRJ_OBJS = $(TMP_DIR)\tls.obj \ + $(TMP_DIR)\tlsBIO.obj \ + $(TMP_DIR)\tlsIO.obj \ + $(TMP_DIR)\tlsX509.obj -PRJ_INCLUDES = -I"$(SSL_INSTALL_FOLDER)\include" -PRJ_DEFINES = -D NO_SSL2 -D NO_SSL3 -D _CRT_SECURE_NO_WARNINGS +# Define any additional project include flags +# SSL_INSTALL_FOLDER = with the OpenSSL installation folder following. +PRJ_INCLUDES = -I"$(SSL_INSTALL_FOLDER)\include" -I"$(OPENSSL_INSTALL_DIR)\include" +# Define any additional compiler flags that might be required for the project +PRJ_DEFINES = -D NO_SSL2 -D NO_SSL3 -D _CRT_SECURE_NO_WARNINGS + +# SSL Libs: +# 1. ${LIBCRYPTO}.dll +# 2. ${LIBSSL}.dll +# Where LIBCRYPTO (#1.) and LIBSSL (#2.) are defined as follows: +# v1.1: libcrypto-1.1-x64.dll and libssl-1.1-x64.dll +# v3: libcrypto-3-x64.dll and libssl-3-x64.dll +# On *nix libcrypto.so.* and libssl.so.* (where suffix is a version indicator). +# PRJ_LIBS = \ "$(SSL_INSTALL_FOLDER)\lib\libssl.lib" \ "$(SSL_INSTALL_FOLDER)\lib\libcrypto.lib" \ WS2_32.LIB GDI32.LIB ADVAPI32.LIB CRYPT32.LIB USER32.LIB -PRJ_OBJS = $(TMP_DIR)\tls.obj \ - $(TMP_DIR)\tlsBIO.obj \ - $(TMP_DIR)\tlsIO.obj \ - $(TMP_DIR)\tlsX509.obj - -!include "rules-ext.vc" +# Define the standard targets !include "targets.vc" +# Project specific targets + +# We must define a pkgindex target that will create a pkgIndex.tcl +# file in the $(OUT_DIR) directory. We can just redirect to the +# default-pkgindex target for our sample extension. pkgindex: default-pkgindex +# The default install target only installs binaries and scripts so add +# an additional target for our documentation. Note this *adds* a target +# since no commands are listed after it. The original targets for +# install (from targets.vc) will remain. +install: default-pkgindex-tea default-install default-install-docs-html + +# Test package +test: default-test ADDED win/rules-ext.vc Index: win/rules-ext.vc ================================================================== --- /dev/null +++ win/rules-ext.vc @@ -0,0 +1,123 @@ +# This file should only be included in makefiles for Tcl extensions, +# NOT in the makefile for Tcl itself. + +!ifndef _RULES_EXT_VC + +# We need to run from the directory the parent makefile is located in. +# nmake does not tell us what makefile was used to invoke it so parent +# makefile has to set the MAKEFILEVC macro or we just make a guess and +# warn if we think that is not the case. +!if "$(MAKEFILEVC)" == "" + +!if exist("$(PROJECT).vc") +MAKEFILEVC = $(PROJECT).vc +!elseif exist("makefile.vc") +MAKEFILEVC = makefile.vc +!endif +!endif # "$(MAKEFILEVC)" == "" + +!if !exist("$(MAKEFILEVC)") +MSG = ^ +You must run nmake from the directory containing the project makefile.^ +If you are doing that and getting this message, set the MAKEFILEVC^ +macro to the name of the project makefile. +!message WARNING: $(MSG) +!endif + +!if "$(PROJECT)" == "tcl" +!error The rules-ext.vc file is not intended for Tcl itself. +!endif + +# We extract version numbers using the nmakehlp program. For now use +# the local copy of nmakehlp. Once we locate Tcl, we will use that +# one if it is newer. +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +!if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] +!endif +!else +!if [copy x86_64-w64-mingw32-nmakehlp.exe nmakehlp.exe >NUL] +!endif +!endif + +# First locate the Tcl directory that we are working with. +!if "$(TCLDIR)" != "" + +_RULESDIR = $(TCLDIR:/=\) + +!else + +# If an installation path is specified, that is also the Tcl directory. +# Also Tk never builds against an installed Tcl, it needs Tcl sources +!if defined(INSTALLDIR) && "$(PROJECT)" != "tk" +_RULESDIR=$(INSTALLDIR:/=\) +!else +# Locate Tcl sources +!if [echo _RULESDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +_RULESDIR = ..\..\tcl +!else +!include nmakehlp.out +!endif + +!endif # defined(INSTALLDIR).... + +!endif # ifndef TCLDIR + +# Now look for the targets.vc file under the Tcl root. Note we check this +# file and not rules.vc because the latter also exists on older systems. +!if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl +_RULESDIR = $(_RULESDIR)\lib\nmake +!elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources +_RULESDIR = $(_RULESDIR)\win +!else +# If we have not located Tcl's targets file, most likely we are compiling +# against an older version of Tcl and so must use our own support files. +_RULESDIR = . +!endif + +!if "$(_RULESDIR)" != "." +# Potentially using Tcl's support files. If this extension has its own +# nmake support files, need to compare the versions and pick newer. + +!if exist("rules.vc") # The extension has its own copy + +!if [echo TCL_RULES_MAJOR = \> versions.vc] \ + && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] +!endif +!if [echo TCL_RULES_MINOR = \>> versions.vc] \ + && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] +!endif + +!if [echo OUR_RULES_MAJOR = \>> versions.vc] \ + && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] +!endif +!if [echo OUR_RULES_MINOR = \>> versions.vc] \ + && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] +!endif +!include versions.vc +# We have a newer version of the support files, use them +!if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) +_RULESDIR = . +!endif + +!endif # if exist("rules.vc") + +!endif # if $(_RULESDIR) != "." + +# Let rules.vc know what copy of nmakehlp.c to use. +NMAKEHLPC = $(_RULESDIR)\nmakehlp.c + +# Get rid of our internal defines before calling rules.vc +!undef TCL_RULES_MAJOR +!undef TCL_RULES_MINOR +!undef OUR_RULES_MAJOR +!undef OUR_RULES_MINOR + +!if exist("$(_RULESDIR)\rules.vc") +!message *** Using $(_RULESDIR)\rules.vc +!include "$(_RULESDIR)\rules.vc" +!else +!error *** Could not locate rules.vc in $(_RULESDIR) +!endif + +!endif # _RULES_EXT_VC ADDED win/rules.vc Index: win/rules.vc ================================================================== --- /dev/null +++ win/rules.vc @@ -0,0 +1,1915 @@ +#------------------------------------------------------------- -*- makefile -*- +# rules.vc -- +# +# Part of the nmake based build system for Tcl and its extensions. +# This file does all the hard work in terms of parsing build options, +# compiler switches, defining common targets and macros. The Tcl makefile +# directly includes this. Extensions include it via "rules-ext.vc". +# +# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for +# detailed documentation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Copyright (c) 2001-2003 David Gravereaux. +# Copyright (c) 2003-2008 Patrick Thoyts +# Copyright (c) 2017 Ashok P. Nadkarni +#------------------------------------------------------------------------------ + +!ifndef _RULES_VC +_RULES_VC = 1 + +# The following macros define the version of the rules.vc nmake build system +# For modifications that are not backward-compatible, you *must* change +# the major version. +RULES_VERSION_MAJOR = 1 +RULES_VERSION_MINOR = 11 + +# The PROJECT macro must be defined by parent makefile. +!if "$(PROJECT)" == "" +!error *** Error: Macro PROJECT not defined! Please define it before including rules.vc +!endif + +!if "$(PRJ_PACKAGE_TCLNAME)" == "" +PRJ_PACKAGE_TCLNAME = $(PROJECT) +!endif + +# Also special case Tcl and Tk to save some typing later +DOING_TCL = 0 +DOING_TK = 0 +!if "$(PROJECT)" == "tcl" +DOING_TCL = 1 +!elseif "$(PROJECT)" == "tk" +DOING_TK = 1 +!endif + +!ifndef NEED_TK +# Backwards compatibility +!ifdef PROJECT_REQUIRES_TK +NEED_TK = $(PROJECT_REQUIRES_TK) +!else +NEED_TK = 0 +!endif +!endif + +!ifndef NEED_TCL_SOURCE +NEED_TCL_SOURCE = 0 +!endif + +!ifdef NEED_TK_SOURCE +!if $(NEED_TK_SOURCE) +NEED_TK = 1 +!endif +!else +NEED_TK_SOURCE = 0 +!endif + +################################################################ +# Nmake is a pretty weak environment in syntax and capabilities +# so this file is necessarily verbose. It's broken down into +# the following parts. +# +# 0. Sanity check that compiler environment is set up and initialize +# any built-in settings from the parent makefile +# 1. First define the external tools used for compiling, copying etc. +# as this is independent of everything else. +# 2. Figure out our build structure in terms of the directory, whether +# we are building Tcl or an extension, etc. +# 3. Determine the compiler and linker versions +# 4. Build the nmakehlp helper application +# 5. Determine the supported compiler options and features +# 6. Extract Tcl, Tk, and possibly extensions, version numbers from the +# headers +# 7. Parse the OPTS macro value for user-specified build configuration +# 8. Parse the STATS macro value for statistics instrumentation +# 9. Parse the CHECKS macro for additional compilation checks +# 10. Based on this selected configuration, construct the output +# directory and file paths +# 11. Construct the paths where the package is to be installed +# 12. Set up the actual options passed to compiler and linker based +# on the information gathered above. +# 13. Define some standard build targets and implicit rules. These may +# be optionally disabled by the parent makefile. +# 14. (For extensions only.) Compare the configuration of the target +# Tcl and the extensions and warn against discrepancies. +# +# One final note about the macro names used. They are as they are +# for historical reasons. We would like legacy extensions to +# continue to work with this make include file so be wary of +# changing them for consistency or clarity. + +# 0. Sanity check compiler environment + +# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or +# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) + +!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) +MSG = ^ +Visual C++ compiler environment not initialized. +!error $(MSG) +!endif + +# We need to run from the directory the parent makefile is located in. +# nmake does not tell us what makefile was used to invoke it so parent +# makefile has to set the MAKEFILEVC macro or we just make a guess and +# warn if we think that is not the case. +!if "$(MAKEFILEVC)" == "" + +!if exist("$(PROJECT).vc") +MAKEFILEVC = $(PROJECT).vc +!elseif exist("makefile.vc") +MAKEFILEVC = makefile.vc +!endif +!endif # "$(MAKEFILEVC)" == "" + +!if !exist("$(MAKEFILEVC)") +MSG = ^ +You must run nmake from the directory containing the project makefile.^ +If you are doing that and getting this message, set the MAKEFILEVC^ +macro to the name of the project makefile. +!message WARNING: $(MSG) +!endif + + +################################################################ +# 1. Define external programs being used + +#---------------------------------------------------------- +# Set the proper copy method to avoid overwrite questions +# to the user when copying files and selecting the right +# "delete all" method. +#---------------------------------------------------------- + +RMDIR = rmdir /S /Q +CPY = xcopy /i /y >NUL +CPYDIR = xcopy /e /i /y >NUL +COPY = copy /y >NUL +MKDIR = mkdir + +###################################################################### +# 2. Figure out our build environment in terms of what we're building. +# +# (a) Tcl itself +# (b) Tk +# (c) a Tcl extension using libraries/includes from an *installed* Tcl +# (d) a Tcl extension using libraries/includes from Tcl source directory +# +# This last is needed because some extensions still need +# some Tcl interfaces that are not publicly exposed. +# +# The fragment will set the following macros: +# ROOT - root of this module sources +# COMPATDIR - source directory that holds compatibility sources +# DOCDIR - source directory containing documentation files +# GENERICDIR - platform-independent source directory +# WIN_DIR - Windows-specific source directory +# TESTDIR - directory containing test files +# TOOLSDIR - directory containing build tools +# _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set +# when building Tcl itself. +# _INSTALLDIR - native form of the installation path. For Tcl +# this will be the root of the Tcl installation. For extensions +# this will be the lib directory under the root. +# TCLINSTALL - set to 1 if _TCLDIR refers to +# headers and libraries from an installed Tcl, and 0 if built against +# Tcl sources. Not set when building Tcl itself. Yes, not very well +# named. +# _TCL_H - native path to the tcl.h file +# +# If Tk is involved, also sets the following +# _TKDIR - native form Tk installation OR Tk source. Not set if building +# Tk itself. +# TKINSTALL - set 1 if _TKDIR refers to installed Tk and 0 if Tk sources +# _TK_H - native path to the tk.h file + +# Root directory for sources and assumed subdirectories +ROOT = $(MAKEDIR)\.. +# The following paths CANNOT have spaces in them as they appear on the +# left side of implicit rules. +!ifndef COMPATDIR +COMPATDIR = $(ROOT)\compat +!endif +!ifndef DOCDIR +DOCDIR = $(ROOT)\doc +!endif +!ifndef GENERICDIR +GENERICDIR = $(ROOT)\generic +!endif +!ifndef TOOLSDIR +TOOLSDIR = $(ROOT)\tools +!endif +!ifndef TESTDIR +TESTDIR = $(ROOT)\tests +!endif +!ifndef LIBDIR +!if exist("$(ROOT)\library") +LIBDIR = $(ROOT)\library +!else +LIBDIR = $(ROOT)\lib +!endif +!endif +!ifndef DEMODIR +!if exist("$(LIBDIR)\demos") +DEMODIR = $(LIBDIR)\demos +!else +DEMODIR = $(ROOT)\demos +!endif +!endif # ifndef DEMODIR +# Do NOT use WINDIR because it is Windows internal environment +# variable to point to c:\windows! +WIN_DIR = $(ROOT)\win + +!ifndef RCDIR +!if exist("$(WIN_DIR)\rc") +RCDIR = $(WIN_DIR)\rc +!else +RCDIR = $(WIN_DIR) +!endif +!endif +RCDIR = $(RCDIR:/=\) + +# The target directory where the built packages and binaries will be installed. +# INSTALLDIR is the (optional) path specified by the user. +# _INSTALLDIR is INSTALLDIR using the backslash separator syntax +!ifdef INSTALLDIR +### Fix the path separators. +_INSTALLDIR = $(INSTALLDIR:/=\) +!else +### Assume the normal default. +_INSTALLDIR = $(HOMEDRIVE)\Tcl +!endif + +!if $(DOING_TCL) + +# BEGIN Case 2(a) - Building Tcl itself + +# Only need to define _TCL_H +_TCL_H = ..\generic\tcl.h + +# END Case 2(a) - Building Tcl itself + +!elseif $(DOING_TK) + +# BEGIN Case 2(b) - Building Tk + +TCLINSTALL = 0 # Tk always builds against Tcl source, not an installed Tcl +!if "$(TCLDIR)" == "" +!if [echo TCLDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +!error *** Could not locate Tcl source directory. +!endif +!include nmakehlp.out +!endif # TCLDIR == "" + +_TCLDIR = $(TCLDIR:/=\) +_TCL_H = $(_TCLDIR)\generic\tcl.h +!if !exist("$(_TCL_H)") +!error Could not locate tcl.h. Please set the TCLDIR macro to point to the Tcl *source* directory. +!endif + +_TK_H = ..\generic\tk.h + +# END Case 2(b) - Building Tk + +!else + +# BEGIN Case 2(c) or (d) - Building an extension other than Tk + +# If command line has specified Tcl location through TCLDIR, use it +# else default to the INSTALLDIR setting +!if "$(TCLDIR)" != "" + +_TCLDIR = $(TCLDIR:/=\) +!if exist("$(_TCLDIR)\include\tcl.h") # Case 2(c) with TCLDIR defined +TCLINSTALL = 1 +_TCL_H = $(_TCLDIR)\include\tcl.h +!elseif exist("$(_TCLDIR)\generic\tcl.h") # Case 2(d) with TCLDIR defined +TCLINSTALL = 0 +_TCL_H = $(_TCLDIR)\generic\tcl.h +!endif + +!else # # Case 2(c) for extensions with TCLDIR undefined + +# Need to locate Tcl depending on whether it needs Tcl source or not. +# If we don't, check the INSTALLDIR for an installed Tcl first + +!if exist("$(_INSTALLDIR)\include\tcl.h") && !$(NEED_TCL_SOURCE) + +TCLINSTALL = 1 +TCLDIR = $(_INSTALLDIR)\.. +# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions +# later so the \.. accounts for the /lib +_TCLDIR = $(_INSTALLDIR)\.. +_TCL_H = $(_TCLDIR)\include\tcl.h + +!else # exist(...) && !$(NEED_TCL_SOURCE) + +!if [echo _TCLDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tcl.h >> nmakehlp.out] +!error *** Could not locate Tcl source directory. +!endif +!include nmakehlp.out +TCLINSTALL = 0 +TCLDIR = $(_TCLDIR) +_TCL_H = $(_TCLDIR)\generic\tcl.h + +!endif # exist(...) && !$(NEED_TCL_SOURCE) + +!endif # TCLDIR + +!ifndef _TCL_H +MSG =^ +Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. +!error $(MSG) +!endif + +# Now do the same to locate Tk headers and libs if project requires Tk +!if $(NEED_TK) + +!if "$(TKDIR)" != "" + +_TKDIR = $(TKDIR:/=\) +!if exist("$(_TKDIR)\include\tk.h") +TKINSTALL = 1 +_TK_H = $(_TKDIR)\include\tk.h +!elseif exist("$(_TKDIR)\generic\tk.h") +TKINSTALL = 0 +_TK_H = $(_TKDIR)\generic\tk.h +!endif + +!else # TKDIR not defined + +# Need to locate Tcl depending on whether it needs Tcl source or not. +# If we don't, check the INSTALLDIR for an installed Tcl first + +!if exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +TKINSTALL = 1 +# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions +# later so the \.. accounts for the /lib +_TKDIR = $(_INSTALLDIR)\.. +_TK_H = $(_TKDIR)\include\tk.h +TKDIR = $(_TKDIR) + +!else # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +!if [echo _TKDIR = \> nmakehlp.out] \ + || [nmakehlp -L generic\tk.h >> nmakehlp.out] +!error *** Could not locate Tk source directory. +!endif +!include nmakehlp.out +TKINSTALL = 0 +TKDIR = $(_TKDIR) +_TK_H = $(_TKDIR)\generic\tk.h + +!endif # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) + +!endif # TKDIR + +!ifndef _TK_H +MSG =^ +Failed to find tk.h. The TKDIR macro is set incorrectly or is not set and default path does not contain tk.h. +!error $(MSG) +!endif + +!endif # NEED_TK + +!if $(NEED_TCL_SOURCE) && $(TCLINSTALL) +MSG = ^ +*** Warning: This extension requires the source distribution of Tcl.^ +*** Please set the TCLDIR macro to point to the Tcl sources. +!error $(MSG) +!endif + +!if $(NEED_TK_SOURCE) +!if $(TKINSTALL) +MSG = ^ +*** Warning: This extension requires the source distribution of Tk.^ +*** Please set the TKDIR macro to point to the Tk sources. +!error $(MSG) +!endif +!endif + + +# If INSTALLDIR set to Tcl installation root dir then reset to the +# lib dir for installing extensions +!if exist("$(_INSTALLDIR)\include\tcl.h") +_INSTALLDIR=$(_INSTALLDIR)\lib +!endif + +# END Case 2(c) or (d) - Building an extension +!endif # if $(DOING_TCL) + +################################################################ +# 3. Determine compiler version and architecture +# In this section, we figure out the compiler version and the +# architecture for which we are building. This sets the +# following macros: +# VCVERSION - the internal compiler version as 1200, 1400, 1910 etc. +# This is also printed by the compiler in dotted form 19.10 etc. +# VCVER - the "marketing version", for example Visual C++ 6 for internal +# compiler version 1200. This is kept only for legacy reasons as it +# does not make sense for recent Microsoft compilers. Only used for +# output directory names. +# ARCH - set to IX86, ARM64 or AMD64 depending on 32- or 64-bit target +# NATIVE_ARCH - set to IX86, ARM64 or AMD64 for the host machine +# MACHINE - same as $(ARCH) - legacy +# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed + +cc32 = $(CC) # built-in default. +link32 = link +lib32 = lib +rc32 = $(RC) # built-in default. + +#---------------------------------------------------------------- +# Figure out the compiler architecture and version by writing +# the C macros to a file, preprocessing them with the C +# preprocessor and reading back the created file + +_HASH=^# +_VC_MANIFEST_EMBED_EXE= +_VC_MANIFEST_EMBED_DLL= +VCVER=0 +!if ![echo VCVERSION=_MSC_VER > vercl.x] \ + && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \ + && ![echo ARCH=IX86 >> vercl.x] \ + && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ + && ![echo ARCH=AMD64 >> vercl.x] \ + && ![echo $(_HASH)elif defined(_M_ARM64) >> vercl.x] \ + && ![echo ARCH=ARM64 >> vercl.x] \ + && ![echo $(_HASH)endif >> vercl.x] \ + && ![$(cc32) -nologo -TC -P vercl.x 2>NUL] +!include vercl.i +!if $(VCVERSION) < 1900 +!if ![echo VCVER= ^\> vercl.vc] \ + && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc] +!include vercl.vc +!endif +!else +# The simple calculation above does not apply to new Visual Studio releases +# Keep the compiler version in its native form. +VCVER = $(VCVERSION) +!endif +!endif + +!if ![del 2>NUL /q/f vercl.x vercl.i vercl.vc] +!endif + +#---------------------------------------------------------------- +# The MACHINE macro is used by legacy makefiles so set it as well +!ifdef MACHINE +!if "$(MACHINE)" == "x86" +!undef MACHINE +MACHINE = IX86 +!elseif "$(MACHINE)" == "arm64" +!undef MACHINE +MACHINE = ARM64 +!elseif "$(MACHINE)" == "x64" +!undef MACHINE +MACHINE = AMD64 +!endif +!if "$(MACHINE)" != "$(ARCH)" +!error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). +!endif +!else +MACHINE=$(ARCH) +!endif + +#--------------------------------------------------------------- +# The PLATFORM_IDENTIFY macro matches the values returned by +# the Tcl platform::identify command +!if "$(MACHINE)" == "AMD64" +PLATFORM_IDENTIFY = win32-x86_64 +!elseif "$(MACHINE)" == "ARM64" +PLATFORM_IDENTIFY = win32-arm +!else +PLATFORM_IDENTIFY = win32-ix86 +!endif + +# The MULTIPLATFORM macro controls whether binary extensions are installed +# in platform-specific directories. Intended to be set/used by extensions. +!ifndef MULTIPLATFORM_INSTALL +MULTIPLATFORM_INSTALL = 0 +!endif + +#------------------------------------------------------------ +# Figure out the *host* architecture by reading the registry + +!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] +NATIVE_ARCH=IX86 +!elseif ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i ARM | findstr /i 64-bit] +NATIVE_ARCH=ARM64 +!else +NATIVE_ARCH=AMD64 +!endif + +# Since MSVC8 we must deal with manifest resources. +!if $(VCVERSION) >= 1400 +_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 +_VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 +!endif + +################################################################ +# 4. Build the nmakehlp program +# This is a helper app we need to overcome nmake's limiting +# environment. We will call out to it to get various bits of +# information about supported compiler options etc. +# +# Tcl itself will always use the nmakehlp.c program which is +# in its own source. It will be kept updated there. +# +# Extensions built against an installed Tcl will use the installed +# copy of Tcl's nmakehlp.c if there is one and their own version +# otherwise. In the latter case, they would also be using their own +# rules.vc. Note that older versions of Tcl do not install nmakehlp.c +# or rules.vc. +# +# Extensions built against Tcl sources will use the one from the Tcl source. +# +# When building an extension using a sufficiently new version of Tcl, +# rules-ext.vc will define NMAKEHLPC appropriately to point to the +# copy of nmakehlp.c to be used. + +!ifndef NMAKEHLPC +# Default to the one in the current directory (the extension's own nmakehlp.c) +NMAKEHLPC = nmakehlp.c + +!if !$(DOING_TCL) +!if $(TCLINSTALL) +!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") +NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c +!endif +!else # !$(TCLINSTALL) +!if exist("$(_TCLDIR)\win\nmakehlp.c") +NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c +!endif +!endif # $(TCLINSTALL) +!endif # !$(DOING_TCL) + +!endif # NMAKEHLPC + +# We always build nmakehlp even if it exists since we do not know +# what source it was built from. +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +!if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] +!endif +!else +!if [copy $(NMAKEHLPC:nmakehlp.c=x86_64-w64-mingw32-nmakehlp.exe) nmakehlp.exe >NUL] +!endif +!endif + +################################################################ +# 5. Test for compiler features +# Visual C++ compiler options have changed over the years. Check +# which options are supported by the compiler in use. +# +# The following macros are set: +# OPTIMIZATIONS - the compiler flags to be used for optimized builds +# DEBUGFLAGS - the compiler flags to be used for debug builds +# LINKERFLAGS - Flags passed to the linker +# +# Note that these are the compiler settings *available*, not those +# that will be *used*. The latter depends on the OPTS macro settings +# which we have not yet parsed. +# +# Also note that some of the flags in OPTIMIZATIONS are not really +# related to optimization. They are placed there only for legacy reasons +# as some extensions expect them to be included in that macro. + +# -Op improves float consistency. Note only needed for older compilers +# Newer compilers do not need or support this option. +!if [nmakehlp -c -Op] +FPOPTS = -Op +!endif + +# Strict floating point semantics - present in newer compilers in lieu of -Op +!if [nmakehlp -c -fp:strict] +FPOPTS = $(FPOPTS) -fp:strict +!endif + +!if "$(MACHINE)" == "IX86" +### test for pentium errata +!if [nmakehlp -c -QI0f] +!message *** Compiler has 'Pentium 0x0f fix' +FPOPTS = $(FPOPTS) -QI0f +!else +!message *** Compiler does not have 'Pentium 0x0f fix' +!endif +!endif + +### test for optimizations +# /O2 optimization includes /Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy as per +# documentation. Note we do NOT want /Gs as that inserts a _chkstk +# stack probe at *every* function entry, not just those with more than +# a page of stack allocation resulting in a performance hit. However, +# /O2 documentation is misleading as its stack probes are simply the +# default page size locals allocation probes and not what is implied +# by an explicit /Gs option. + +OPTIMIZATIONS = $(FPOPTS) + +!if [nmakehlp -c -O2] +OPTIMIZING = 1 +OPTIMIZATIONS = $(OPTIMIZATIONS) -O2 +!else +# Legacy, really. All modern compilers support this +!message *** Compiler does not have 'Optimizations' +OPTIMIZING = 0 +!endif + +# Checks for buffer overflows in local arrays +!if [nmakehlp -c -GS] +OPTIMIZATIONS = $(OPTIMIZATIONS) -GS +!endif + +# Link time optimization. Note that this option (potentially) makes +# generated libraries only usable by the specific VC++ version that +# created it. Requires /LTCG linker option +!if [nmakehlp -c -GL] +OPTIMIZATIONS = $(OPTIMIZATIONS) -GL +CC_GL_OPT_ENABLED = 1 +!else +# In newer compilers -GL and -YX are incompatible. +!if [nmakehlp -c -YX] +OPTIMIZATIONS = $(OPTIMIZATIONS) -YX +!endif +!endif # [nmakehlp -c -GL] + +DEBUGFLAGS = $(FPOPTS) + +# Run time error checks. Not available or valid in a release, non-debug build +# RTC is for modern compilers, -GZ is legacy +!if [nmakehlp -c -RTC1] +DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 +!elseif [nmakehlp -c -GZ] +DEBUGFLAGS = $(DEBUGFLAGS) -GZ +!endif + +#---------------------------------------------------------------- +# Linker flags + +# LINKER_TESTFLAGS are for internal use when we call nmakehlp to test +# if the linker supports a specific option. Without these flags link will +# return "LNK1561: entry point must be defined" error compiling from VS-IDE: +# They are not passed through to the actual application / extension +# link rules. +!ifndef LINKER_TESTFLAGS +LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmakehlp.out +!endif + +LINKERFLAGS = + +# If compiler has enabled link time optimization, linker must too with -ltcg +!ifdef CC_GL_OPT_ENABLED +!if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS) -ltcg +!endif +!endif + + +################################################################ +# 6. Extract various version numbers from headers +# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h +# respectively. For extensions, versions are extracted from the +# configure.in or configure.ac from the TEA configuration if it +# exists, and unset otherwise. +# Sets the following macros: +# TCL_MAJOR_VERSION +# TCL_MINOR_VERSION +# TCL_RELEASE_SERIAL +# TCL_PATCH_LEVEL +# TCL_PATCH_LETTER +# TCL_VERSION +# TK_MAJOR_VERSION +# TK_MINOR_VERSION +# TK_RELEASE_SERIAL +# TK_PATCH_LEVEL +# TK_PATCH_LETTER +# TK_VERSION +# DOTVERSION - set as (for example) 2.5 +# VERSION - set as (for example 25) +#-------------------------------------------------------------- + +!if [echo REM = This file is generated from rules.vc > versions.vc] +!endif +!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] +!endif +!if [echo TCL_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] +!endif +!if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] +!endif +!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] +!endif + +!if defined(_TK_H) +!if [echo TK_MAJOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) "define TK_MAJOR_VERSION" >> versions.vc] +!endif +!if [echo TK_MINOR_VERSION = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] +!endif +!if [echo TK_RELEASE_SERIAL = \>> versions.vc] \ + && [nmakehlp -V "$(_TK_H)" TK_RELEASE_SERIAL >> versions.vc] +!endif +!if [echo TK_PATCH_LEVEL = \>> versions.vc] \ + && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] +!endif +!endif # _TK_H + +!include versions.vc + +TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) +TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +!if [nmakehlp -f $(TCL_PATCH_LEVEL) "a"] +TCL_PATCH_LETTER = a +!elseif [nmakehlp -f $(TCL_PATCH_LEVEL) "b"] +TCL_PATCH_LETTER = b +!else +TCL_PATCH_LETTER = . +!endif + +!if defined(_TK_H) + +TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) +TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) +!if [nmakehlp -f $(TK_PATCH_LEVEL) "a"] +TK_PATCH_LETTER = a +!elseif [nmakehlp -f $(TK_PATCH_LEVEL) "b"] +TK_PATCH_LETTER = b +!else +TK_PATCH_LETTER = . +!endif + +!endif + +# Set DOTVERSION and VERSION +!if $(DOING_TCL) + +DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +VERSION = $(TCL_VERSION) + +!elseif $(DOING_TK) + +DOTVERSION = $(TK_DOTVERSION) +VERSION = $(TK_VERSION) + +!else # Doing a non-Tk extension + +# If parent makefile has not defined DOTVERSION, try to get it from TEA +# first from a configure.in file, and then from configure.ac +!ifndef DOTVERSION +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] +!if [echo DOTVERSION = \> versions.vc] \ + || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] +!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. +!endif +!endif +!include versions.vc +!endif # DOTVERSION +VERSION = $(DOTVERSION:.=) + +!endif # $(DOING_TCL) ... etc. + +# Windows RC files have 3 version components. Ensure this irrespective +# of how many components the package has specified. Basically, ensure +# minimum 4 components by appending 4 0's and then pick out the first 4. +# Also take care of the fact that DOTVERSION may have "a" or "b" instead +# of "." separating the version components. +DOTSEPARATED=$(DOTVERSION:a=.) +DOTSEPARATED=$(DOTSEPARATED:b=.) +!if [echo RCCOMMAVERSION = \> versions.vc] \ + || [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc] +!error *** Could not generate RCCOMMAVERSION *** +!endif +!include versions.vc + +######################################################################## +# 7. Parse the OPTS macro to work out the requested build configuration. +# Based on this, we will construct the actual switches to be passed to the +# compiler and linker using the macros defined in the previous section. +# The following macros are defined by this section based on OPTS +# STATIC_BUILD - 0 -> Tcl is to be built as a shared library +# 1 -> build as a static library and shell +# TCL_THREADS - legacy but always 1 on Windows since winsock requires it. +# DEBUG - 1 -> debug build, 0 -> release builds +# SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's +# PROFILE - 1 -> generate profiling info, 0 -> no profiling +# PGO - 1 -> profile based optimization, 0 -> no +# MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build +# 0 -> link to static C runtime for static Tcl build. +# Does not impact shared Tcl builds (STATIC_BUILD == 0) +# Default: 1 for Tcl 8.7 and up, 0 otherwise. +# TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions +# in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does +# not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7. +# USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. +# 0 -> Use the non-thread allocator. +# UNCHECKED - 1 -> when doing a debug build with symbols, use the release +# C runtime, 0 -> use the debug C runtime. +# USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking +# CONFIG_CHECK - 1 -> check current build configuration against Tcl +# configuration (ignored for Tcl itself) +# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build +# (CRT library should support this, not needed for Tcl 9.x) +# Further, LINKERFLAGS are modified based on above. + +# Default values for all the above +STATIC_BUILD = 0 +TCL_THREADS = 1 +DEBUG = 0 +SYMBOLS = 0 +PROFILE = 0 +PGO = 0 +MSVCRT = 1 +TCL_USE_STATIC_PACKAGES = 0 +USE_THREAD_ALLOC = 1 +UNCHECKED = 0 +CONFIG_CHECK = 1 +!if $(DOING_TCL) +USE_STUBS = 0 +!else +USE_STUBS = 1 +!endif + +# If OPTS is not empty AND does not contain "none" which turns off all OPTS +# set the above macros based on OPTS content +!if "$(OPTS)" != "" && ![nmakehlp -f "$(OPTS)" "none"] + +# OPTS are specified, parse them + +!if [nmakehlp -f $(OPTS) "static"] +!message *** Doing static +STATIC_BUILD = 1 +!endif + +!if [nmakehlp -f $(OPTS) "nostubs"] +!message *** Not using stubs +USE_STUBS = 0 +!endif + +!if [nmakehlp -f $(OPTS) "nomsvcrt"] +!message *** Doing nomsvcrt +MSVCRT = 0 +!else +!if [nmakehlp -f $(OPTS) "msvcrt"] +!message *** Doing msvcrt +!else +!if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 && $(STATIC_BUILD) +MSVCRT = 0 +!endif +!endif +!endif # [nmakehlp -f $(OPTS) "nomsvcrt"] + +!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) +!message *** Doing staticpkg +TCL_USE_STATIC_PACKAGES = 1 +!endif + +!if [nmakehlp -f $(OPTS) "nothreads"] +!message *** Compile explicitly for non-threaded tcl +TCL_THREADS = 0 +USE_THREAD_ALLOC= 0 +!endif + +!if [nmakehlp -f $(OPTS) "tcl8"] +!message *** Build for Tcl8 +TCL_BUILD_FOR = 8 +!endif + +!if $(TCL_MAJOR_VERSION) == 8 +!if [nmakehlp -f $(OPTS) "time64bit"] +!message *** Force 64-bit time_t +_USE_64BIT_TIME_T = 1 +!endif +!endif + +# Yes, it's weird that the "symbols" option controls DEBUG and +# the "pdbs" option controls SYMBOLS. That's historical. +!if [nmakehlp -f $(OPTS) "symbols"] +!message *** Doing symbols +DEBUG = 1 +!else +DEBUG = 0 +!endif + +!if [nmakehlp -f $(OPTS) "pdbs"] +!message *** Doing pdbs +SYMBOLS = 1 +!else +SYMBOLS = 0 +!endif + +!if [nmakehlp -f $(OPTS) "profile"] +!message *** Doing profile +PROFILE = 1 +!else +PROFILE = 0 +!endif + +!if [nmakehlp -f $(OPTS) "pgi"] +!message *** Doing profile guided optimization instrumentation +PGO = 1 +!elseif [nmakehlp -f $(OPTS) "pgo"] +!message *** Doing profile guided optimization +PGO = 2 +!else +PGO = 0 +!endif + +!if [nmakehlp -f $(OPTS) "loimpact"] +!message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. +!endif + +# TBD - should get rid of this option +!if [nmakehlp -f $(OPTS) "thrdalloc"] +!message *** Doing thrdalloc +USE_THREAD_ALLOC = 1 +!endif + +!if [nmakehlp -f $(OPTS) "tclalloc"] +USE_THREAD_ALLOC = 0 +!endif + +!if [nmakehlp -f $(OPTS) "unchecked"] +!message *** Doing unchecked +UNCHECKED = 1 +!else +UNCHECKED = 0 +!endif + +!if [nmakehlp -f $(OPTS) "noconfigcheck"] +CONFIG_CHECK = 1 +!else +CONFIG_CHECK = 0 +!endif + +!endif # "$(OPTS)" != "" && ... parsing of OPTS + +# Set linker flags based on above + +!if $(PGO) > 1 +!if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!elseif $(PGO) > 0 +!if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument +!else +MSG=^ +This compiler does not support profile guided optimization. +!error $(MSG) +!endif +!endif + +################################################################ +# 8. Parse the STATS macro to configure code instrumentation +# The following macros are set by this section: +# TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation +# 0 -> disables +# TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging +# 0 -> disables + +# Default both are off +TCL_MEM_DEBUG = 0 +TCL_COMPILE_DEBUG = 0 + +!if "$(STATS)" != "" && ![nmakehlp -f "$(STATS)" "none"] + +!if [nmakehlp -f $(STATS) "memdbg"] +!message *** Doing memdbg +TCL_MEM_DEBUG = 1 +!else +TCL_MEM_DEBUG = 0 +!endif + +!if [nmakehlp -f $(STATS) "compdbg"] +!message *** Doing compdbg +TCL_COMPILE_DEBUG = 1 +!else +TCL_COMPILE_DEBUG = 0 +!endif + +!endif + +#################################################################### +# 9. Parse the CHECKS macro to configure additional compiler checks +# The following macros are set by this section: +# WARNINGS - compiler switches that control the warnings level +# TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions +# 0 -> enable deprecated functions + +# Defaults - Permit deprecated functions and warning level 3 +TCL_NO_DEPRECATED = 0 +WARNINGS = -W3 + +!if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"] + +!if [nmakehlp -f $(CHECKS) "nodep"] +!message *** Doing nodep check +TCL_NO_DEPRECATED = 1 +!endif + +!if [nmakehlp -f $(CHECKS) "fullwarn"] +!message *** Doing full warnings check +WARNINGS = -W4 +!if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] +LINKERFLAGS = $(LINKERFLAGS) -warn:3 +!endif +!endif + +!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] +!message *** Doing 64bit portability warnings +WARNINGS = $(WARNINGS) -Wp64 +!endif + +!endif + + +################################################################ +# 10. Construct output directory and file paths +# Figure-out how to name our intermediate and output directories. +# In order to avoid inadvertent mixing of object files built using +# different compilers, build configurations etc., +# +# Naming convention (suffixes): +# t = full thread support. (Not used for Tcl >= 8.7) +# s = static library (as opposed to an import library) +# g = linked to the debug enabled C run-time. +# x = special static build when it links to the dynamic C run-time. +# +# The following macros are set in this section: +# SUFX - the suffix to use for binaries based on above naming convention +# BUILDDIRTOP - the toplevel default output directory +# is of the form {Release,Debug}[_AMD64][_COMPILERVERSION] +# TMP_DIR - directory where object files are created +# OUT_DIR - directory where output executables are created +# Both TMP_DIR and OUT_DIR are defaulted only if not defined by the +# parent makefile (or command line). The default values are +# based on BUILDDIRTOP. +# STUBPREFIX - name of the stubs library for this project +# PRJIMPLIB - output path of the generated project import library +# PRJLIBNAME - name of generated project library +# PRJLIB - output path of generated project library +# PRJSTUBLIBNAME - name of the generated project stubs library +# PRJSTUBLIB - output path of the generated project stubs library +# RESFILE - output resource file (only if not static build) + +SUFX = tsgx + +!if $(DEBUG) +BUILDDIRTOP = Debug +!else +BUILDDIRTOP = Release +!endif + +!if "$(MACHINE)" != "IX86" +BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) +!endif +!if $(VCVER) > 6 +BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) +!endif + +!if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) +SUFX = $(SUFX:g=) +!endif + +TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX + +!if !$(STATIC_BUILD) +TMP_DIRFULL = $(TMP_DIRFULL:Static=) +SUFX = $(SUFX:s=) +EXT = dll +TMP_DIRFULL = $(TMP_DIRFULL:X=) +SUFX = $(SUFX:x=) +!else +TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) +EXT = lib +!if $(MSVCRT) && $(TCL_VERSION) > 86 || !$(MSVCRT) && $(TCL_VERSION) < 87 +TMP_DIRFULL = $(TMP_DIRFULL:X=) +SUFX = $(SUFX:x=) +!endif +!endif + +!if !$(TCL_THREADS) || $(TCL_VERSION) > 86 +TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) +SUFX = $(SUFX:t=) +!endif + +!ifndef TMP_DIR +TMP_DIR = $(TMP_DIRFULL) +!ifndef OUT_DIR +OUT_DIR = .\$(BUILDDIRTOP) +!endif +!else +!ifndef OUT_DIR +OUT_DIR = $(TMP_DIR) +!endif +!endif + +# Relative paths -> absolute +!if [echo OUT_DIR = \> nmakehlp.out] \ + || [nmakehlp -Q "$(OUT_DIR)" >> nmakehlp.out] +!error *** Could not fully qualify path OUT_DIR=$(OUT_DIR) +!endif +!if [echo TMP_DIR = \>> nmakehlp.out] \ + || [nmakehlp -Q "$(TMP_DIR)" >> nmakehlp.out] +!error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) +!endif +!include nmakehlp.out + +# The name of the stubs library for the project being built +STUBPREFIX = $(PROJECT)stub + +# +# Set up paths to various Tcl executables and libraries needed by extensions +# + +# TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc +TCLSCRIPTZIPNAME = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip +TKSCRIPTZIPNAME = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip + +!if $(DOING_TCL) +TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe +TCLSH = $(OUT_DIR)\$(TCLSHNAME) +TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) +TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) + +!if $(TCL_MAJOR_VERSION) == 8 +TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +TCLSTUBLIBNAME = $(STUBPREFIX).lib +!endif +TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) +TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" + +!else # !$(DOING_TCL) + +!if $(TCLINSTALL) # Building against an installed Tcl + +# When building extensions, we need to locate tclsh. Depending on version +# of Tcl we are building against, this may or may not have a "t" suffix. +# Try various possibilities in turn. +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe +!if !exist("$(TCLSH)") +TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe +!endif + +!if $(TCL_MAJOR_VERSION) == 8 +TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib +!endif +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib +# When building extensions, may be linking against Tcl that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TCLIMPLIB)") +TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib +!endif +TCL_LIBRARY = $(_TCLDIR)\lib +TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib +TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib +TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCLSCRIPTZIPNAME) +TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target +TCL_INCLUDES = -I"$(_TCLDIR)\include" + +!else # Building against Tcl sources + +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe +!if !exist($(TCLSH)) +TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe +!endif +!if $(TCL_MAJOR_VERSION) == 8 +TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib +!endif +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib +# When building extensions, may be linking against Tcl that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TCLIMPLIB)") +TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib +!endif +TCL_LIBRARY = $(_TCLDIR)\library +TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib +TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib +TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCLSCRIPTZIPNAME) +TCLTOOLSDIR = $(_TCLDIR)\tools +TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" + +!endif # TCLINSTALL + +!if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8" +tcllibs = "$(TCLSTUBLIB)" +!else +tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" +!endif + +!endif # $(DOING_TCL) + +# We need a tclsh that will run on the host machine as part of the build. +# IX86 runs on all architectures. +!ifndef TCLSH_NATIVE +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +TCLSH_NATIVE = $(TCLSH) +!else +!error You must explicitly set TCLSH_NATIVE for cross-compilation +!endif +!endif + +# Do the same for Tk and Tk extensions that require the Tk libraries +!if $(DOING_TK) || $(NEED_TK) +WISHNAMEPREFIX = wish +WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe +TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) +TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" +TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib +!else +TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) +TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib +!endif +!if $(TK_MAJOR_VERSION) == 8 +TKSTUBLIBNAME = tkstub$(TK_VERSION).lib +!else +TKSTUBLIBNAME = tkstub.lib +!endif + +!if $(DOING_TK) +WISH = $(OUT_DIR)\$(WISHNAME) +TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) +TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) +TKLIB = $(OUT_DIR)\$(TKLIBNAME) +TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" +TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME) + +!else # effectively NEED_TK + +!if $(TKINSTALL) # Building against installed Tk +WISH = $(_TKDIR)\bin\$(WISHNAME) +TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) +TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) +# When building extensions, may be linking against Tk that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TKIMPLIB)") +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib +TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) +!endif +TK_INCLUDES = -I"$(_TKDIR)\include" +TKSCRIPTZIP = $(_TKDIR)\lib\$(TKSCRIPTZIPNAME) + +!else # Building against Tk sources + +WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) +TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME) +TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) +# When building extensions, may be linking against Tk that does not add +# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. +!if !exist("$(TKIMPLIB)") +TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib +TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) +!endif +TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" +TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSCRIPTZIPNAME) + +!endif # TKINSTALL + +tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" + +!endif # $(DOING_TK) +!endif # $(DOING_TK) || $(NEED_TK) + +# Various output paths +PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" +PRJLIBNAME = $(PRJLIBNAME8) +!else +PRJLIBNAME = $(PRJLIBNAME9) +!endif +PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) + +!if $(TCL_MAJOR_VERSION) == 8 +PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +PRJSTUBLIBNAME = $(STUBPREFIX).lib +!endif +PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) + +# If extension parent makefile has not defined a resource definition file, +# we will generate one from standard template. +!if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD) +!ifdef RCFILE +RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res) +!else +RESFILE = $(TMP_DIR)\$(PROJECT).res +!endif +!endif + +################################################################### +# 11. Construct the paths for the installation directories +# The following macros get defined in this section: +# LIB_INSTALL_DIR - where libraries should be installed +# BIN_INSTALL_DIR - where the executables should be installed +# DOC_INSTALL_DIR - where documentation should be installed +# SCRIPT_INSTALL_DIR - where scripts should be installed +# INCLUDE_INSTALL_DIR - where C include files should be installed +# DEMO_INSTALL_DIR - where demos should be installed +# PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk) + +!if $(DOING_TCL) || $(DOING_TK) +LIB_INSTALL_DIR = $(_INSTALLDIR)\lib +BIN_INSTALL_DIR = $(_INSTALLDIR)\bin +DOC_INSTALL_DIR = $(_INSTALLDIR)\doc +!if $(DOING_TCL) +SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) +MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) +!else # DOING_TK +SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) +!endif +DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include + +!else # extension other than Tk + +PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) +!if $(MULTIPLATFORM_INSTALL) +LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) +!else +LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) +BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) +!endif +DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) +SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) +DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include + +!endif + +################################################################### +# 12. Set up actual options to be passed to the compiler and linker +# Now we have all the information we need, set up the actual flags and +# options that we will pass to the compiler and linker. The main +# makefile should use these in combination with whatever other flags +# and switches are specific to it. +# The following macros are defined, names are for historical compatibility: +# OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS +# COMPILERFLAGS - /Dxxx C macro flags independent of any configuration options +# crt - Compiler switch that selects the appropriate C runtime +# cdebug - Compiler switches related to debug AND optimizations +# cwarn - Compiler switches that set warning levels +# cflags - complete compiler switches (subsumes cdebug and cwarn) +# ldebug - Linker switches controlling debug information and optimization +# lflags - complete linker switches (subsumes ldebug) except subsystem type +# dlllflags - complete linker switches to build DLLs (subsumes lflags) +# conlflags - complete linker switches for console program (subsumes lflags) +# guilflags - complete linker switches for GUI program (subsumes lflags) +# baselibs - minimum Windows libraries required. Parent makefile can +# define PRJ_LIBS before including rules.rc if additional libs are needed + +OPTDEFINES = /DSTDC_HEADERS /DUSE_NMAKE=1 +!if $(VCVERSION) > 1600 +OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 +!else +OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 +!endif +!if $(VCVERSION) >= 1800 +OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 +!endif + +!if $(TCL_MEM_DEBUG) +OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG +!endif +!if $(TCL_COMPILE_DEBUG) +OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS +!endif +!if $(TCL_THREADS) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 +!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 +OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 +!endif +!endif +!if $(STATIC_BUILD) +OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD +!elseif $(TCL_VERSION) > 86 +OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" +OPTDEFINES = $(OPTDEFINES) /DMP_64BIT +!endif +!endif +!if $(TCL_NO_DEPRECATED) +OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED +!endif + +!if $(USE_STUBS) +# Note we do not define USE_TCL_STUBS even when building tk since some +# test targets in tk do not use stubs +!if !$(DOING_TCL) +USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS +!if $(NEED_TK) +USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS +!endif +!endif +!endif # USE_STUBS + +!if !$(DEBUG) +OPTDEFINES = $(OPTDEFINES) /DNDEBUG +!if $(OPTIMIZING) +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED +!endif +!endif +!if $(PROFILE) +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED +!endif +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" +OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT +!endif +!if $(VCVERSION) < 1300 +OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 +!endif + +!if $(TCL_MAJOR_VERSION) == 8 +!if "$(_USE_64BIT_TIME_T)" == "1" +OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 +!endif + +# _ATL_XP_TARGETING - Newer SDK's need this to build for XP +COMPILERFLAGS = /D_ATL_XP_TARGETING +!endif +!if "$(TCL_BUILD_FOR)" == "8" +OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 +!endif + +# Like the TEA system only set this non empty for non-Tk extensions +# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME +# so we pass both +!if !$(DOING_TCL) && !$(DOING_TK) +PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ + /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ + /DMODULE_SCOPE=extern +!endif + +# crt picks the C run time based on selected OPTS +!if $(MSVCRT) +!if $(DEBUG) && !$(UNCHECKED) +crt = -MDd +!else +crt = -MD +!endif +!else +!if $(DEBUG) && !$(UNCHECKED) +crt = -MTd +!else +crt = -MT +!endif +!endif + +# cdebug includes compiler options for debugging as well as optimization. +!if $(DEBUG) + +# In debugging mode, optimizations need to be disabled +cdebug = -Zi -Od $(DEBUGFLAGS) + +!else + +cdebug = $(OPTIMIZATIONS) +!if $(SYMBOLS) +cdebug = $(cdebug) -Zi +!endif + +!endif # $(DEBUG) + +# cwarn includes default warning levels, also C4090 (buggy) and C4146 is useless. +cwarn = $(WARNINGS) -wd4090 -wd4146 + +!if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" +# Disable pointer<->int warnings related to cast between different sizes +# There are a gadzillion of these due to use of ClientData and +# clutter up compiler +# output increasing chance of a real warning getting lost. So disable them. +# Eventually some day, Tcl will be 64-bit clean. +cwarn = $(cwarn) -wd4311 -wd4312 +!endif + +### Common compiler options that are architecture specific +!if "$(MACHINE)" == "ARM" +carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE +!else +carch = +!endif + +# cpuid is only available on intel machines +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "AMD64" +carch = $(carch) /DHAVE_CPUID=1 +!endif + +!if $(DEBUG) +# Turn warnings into errors +cwarn = $(cwarn) -WX +!endif + +INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) +!if !$(DOING_TCL) && !$(DOING_TK) +INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" +!endif + +# These flags are defined roughly in the order of the pre-reform +# rules.vc/makefile.vc to help visually compare that the pre- and +# post-reform build logs + +# cflags contains generic flags used for building practically all object files +cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) + +!if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 +cflags = $(cflags) -DTcl_Size=int +!endif + +# appcflags contains $(cflags) and flags for building the application +# object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus +# flags used for building shared object files The two differ in the +# BUILD_$(PROJECT) macro which should be defined only for the shared +# library *implementation* and not for its caller interface + +appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) +appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) +pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) +pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) + +# stubscflags contains $(cflags) plus flags used for building a stubs +# library for the package. Note: /DSTATIC_BUILD is defined in +# $(OPTDEFINES) only if the OPTS configuration indicates a static +# library. However the stubs library is ALWAYS static hence included +# here irrespective of the OPTS setting. +# +# TBD - tclvfs has a comment that stubs libs should not be compiled with -GL +# without stating why. Tcl itself compiled stubs libs with this flag. +# so we do not remove it from cflags. -GL may prevent extensions +# compiled with one VC version to fail to link against stubs library +# compiled with another VC version. Check for this and fix accordingly. +stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) /Zl /GL- /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) + +# Link flags + +!if $(DEBUG) +ldebug = -debug -debugtype:cv +!else +ldebug = -release -opt:ref -opt:icf,3 +!if $(SYMBOLS) +ldebug = $(ldebug) -debug -debugtype:cv +!endif +!endif + +# Note: Profiling is currently only possible with the Visual Studio Enterprise +!if $(PROFILE) +ldebug= $(ldebug) -profile +!endif + +### Declarations common to all linker versions +lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) + +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +lflags = $(lflags) -nodefaultlib:libucrt.lib +!endif + +dlllflags = $(lflags) -dll +conlflags = $(lflags) -subsystem:console +guilflags = $(lflags) -subsystem:windows + +# Libraries that are required for every image. +# Extensions should define any additional libraries with $(PRJ_LIBS) +winlibs = kernel32.lib advapi32.lib + +!if $(NEED_TK) +winlibs = $(winlibs) gdi32.lib user32.lib uxtheme.lib +!endif + +# Avoid 'unresolved external symbol __security_cookie' errors. +# c.f. http://support.microsoft.com/?id=894573 +!if "$(MACHINE)" == "AMD64" +!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 +winlibs = $(winlibs) bufferoverflowU.lib +!endif +!endif + +baselibs = $(winlibs) $(PRJ_LIBS) + +!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 +baselibs = $(baselibs) ucrt.lib +!endif + +################################################################ +# 13. Define standard commands, common make targets and implicit rules + +CCPKGCMD = $(cc32) $(pkgcflags) -Fo$(TMP_DIR)^\ +CCAPPCMD = $(cc32) $(appcflags) -Fo$(TMP_DIR)^\ +CCSTUBSCMD = $(cc32) $(stubscflags) -Fo$(TMP_DIR)^\ + +LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ +DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) + +CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) +GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) +RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ + $(TCL_INCLUDES) /DSTATIC_BUILD=$(STATIC_BUILD) \ + /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ + /DCOMMAVERSION=$(RCCOMMAVERSION) \ + /DDOTVERSION=\"$(DOTVERSION)\" \ + /DVERSION=\"$(VERSION)\" \ + /DSUFX=\"$(SUFX)\" \ + /DPROJECT=\"$(PROJECT)\" \ + /DPRJLIBNAME=\"$(PRJLIBNAME)\" + +!ifndef DEFAULT_BUILD_TARGET +DEFAULT_BUILD_TARGET = $(PROJECT) +!endif + +default-target: $(DEFAULT_BUILD_TARGET) + +!if $(MULTIPLATFORM_INSTALL) +default-pkgindex: + @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl + @echo } else { >> $(OUT_DIR)\pkgIndex.tcl + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl + @echo } >> $(OUT_DIR)\pkgIndex.tcl +!else +default-pkgindex: + @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl + @echo } else { >> $(OUT_DIR)\pkgIndex.tcl + @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ + [list load [file join $$dir $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl + @echo } >> $(OUT_DIR)\pkgIndex.tcl +!endif + +default-pkgindex-tea: + @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl +@PACKAGE_VERSION@ $(DOTVERSION) +@PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME) +@PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME) +@PKG_LIB_FILE@ $(PRJLIBNAME) +@PKG_LIB_FILE8@ $(PRJLIBNAME8) +@PKG_LIB_FILE9@ $(PRJLIBNAME9) +<< + +default-install: default-install-binaries default-install-libraries +!if $(SYMBOLS) +default-install: default-install-pdbs +!endif + +# Again to deal with historical brokenness, there is some confusion +# in terminlogy. For extensions, the "install-binaries" was used to +# locate target directory for *binary shared libraries* and thus +# the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is +# for executables (exes). On the other hand the "install-libraries" +# target is for *scripts* and should have been called "install-scripts". +default-install-binaries: $(PRJLIB) + @echo Installing binaries to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL + +# Alias for default-install-scripts +default-install-libraries: default-install-scripts + +default-install-scripts: $(OUT_DIR)\pkgIndex.tcl + @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' + @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" + @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' + @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) + +default-install-stubs: + @echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)' + @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" + @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL + +default-install-pdbs: + @echo Installing PDBs to '$(LIB_INSTALL_DIR)' + @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" + @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" + +# "emacs font-lock highlighting fix + +default-install-docs-html: + @echo Installing documentation files to '$(DOC_INSTALL_DIR)' + @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" + @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)" + +default-install-docs-n: + @echo Installing documentation files to '$(DOC_INSTALL_DIR)' + @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" + @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.n") do @$(COPY) %f "$(DOC_INSTALL_DIR)" + +default-install-demos: + @echo Installing demos to '$(DEMO_INSTALL_DIR)' + @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" + @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" + +default-clean: + @echo Cleaning $(TMP_DIR)\* ... + @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) + @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... + @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj + @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe + @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out + @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... + @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt + @echo Cleaning $(WIN_DIR)\_junk.pch ... + @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch + @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... + @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x + @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i + @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... + @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc + @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc + +default-hose: default-clean + @echo Hosing $(OUT_DIR)\* ... + @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Only for backward compatibility +default-distclean: default-hose + +default-setup: + @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) + @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) + +!if "$(TESTPAT)" != "" +TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) +!endif + +default-test: default-setup $(PROJECT) + @set TCLLIBPATH=$(OUT_DIR:\=/) + @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" + cd "$(TESTDIR)" && $(DEBUGGER) $(TCLSH) all.tcl $(TESTFLAGS) + +default-shell: default-setup $(PROJECT) + @set TCLLIBPATH=$(OUT_DIR:\=/) + @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" + $(DEBUGGER) $(TCLSH) + +# Generation of Windows version resource +!ifdef RCFILE + +# Note: don't use $** in below rule because there may be other dependencies +# and only the "main" rc must be passed to the resource compiler +$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc + $(RESCMD) $(RCDIR)\$(PROJECT).rc + +!else + +# If parent makefile has not defined a resource definition file, +# we will generate one from standard template. +$(TMP_DIR)\$(PROJECT).res: $(TMP_DIR)\$(PROJECT).rc + +$(TMP_DIR)\$(PROJECT).rc: + @$(COPY) << $(TMP_DIR)\$(PROJECT).rc +#include + +VS_VERSION_INFO VERSIONINFO + FILEVERSION COMMAVERSION + PRODUCTVERSION COMMAVERSION + FILEFLAGSMASK 0x3fL +#ifdef DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS_NT_WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcl extension " PROJECT + VALUE "OriginalFilename", PRJLIBNAME + VALUE "FileVersion", DOTVERSION + VALUE "ProductName", "Package " PROJECT " for Tcl" + VALUE "ProductVersion", DOTVERSION + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + +<< + +!endif # ifdef RCFILE + +!ifndef DISABLE_IMPLICIT_RULES +DISABLE_IMPLICIT_RULES = 0 +!endif + +!if !$(DISABLE_IMPLICIT_RULES) +# Implicit rule definitions - only for building library objects. For stubs and +# main application, the makefile should define explicit rules. + +{$(ROOT)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(WIN_DIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + +{$(RCDIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +{$(WIN_DIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +{$(TMP_DIR)}.rc{$(TMP_DIR)}.res: + $(RESCMD) $< + +.SUFFIXES: +.SUFFIXES:.c .rc + +!endif + +################################################################ +# 14. Sanity check selected options against Tcl build options +# When building an extension, certain configuration options should +# match the ones used when Tcl was built. Here we check and +# warn on a mismatch. +!if !$(DOING_TCL) + +!if $(TCLINSTALL) # Building against an installed Tcl +!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") +TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" +!endif +!else # !$(TCLINSTALL) - building against Tcl source +!if exist("$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake") +TCLNMAKECONFIG = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake" +!endif +!endif # TCLINSTALL + +!if $(CONFIG_CHECK) +!ifdef TCLNMAKECONFIG +!include $(TCLNMAKECONFIG) + +!if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" +!error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). +!endif +!if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) +!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). +!endif +!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) +!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). +!endif +!endif + +!endif # TCLNMAKECONFIG + +!endif # !$(DOING_TCL) + + +#---------------------------------------------------------- +# Display stats being used. +#---------------------------------------------------------- + +!if !$(DOING_TCL) +!message *** Building against Tcl at '$(_TCLDIR)' +!endif +!if !$(DOING_TK) && $(NEED_TK) +!message *** Building against Tk at '$(_TKDIR)' +!endif +!message *** Intermediate directory will be '$(TMP_DIR)' +!message *** Output directory will be '$(OUT_DIR)' +!message *** Installation, if selected, will be in '$(_INSTALLDIR)' +!message *** Suffix for binaries will be '$(SUFX)' +!message *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH). + +!endif # ifdef _RULES_VC ADDED win/svnmanifest.in Index: win/svnmanifest.in ================================================================== --- /dev/null +++ win/svnmanifest.in @@ -0,0 +1,1 @@ +svn-r Index: win/targets.vc ================================================================== --- win/targets.vc +++ win/targets.vc @@ -2,11 +2,11 @@ # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. -# See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for docs. +# See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) ADDED win/x86_64-w64-mingw32-nmakehlp.exe Index: win/x86_64-w64-mingw32-nmakehlp.exe ================================================================== --- /dev/null +++ win/x86_64-w64-mingw32-nmakehlp.exe cannot compute difference between binary files