DELETED HEADER
Index: HEADER
==================================================================
--- HEADER
+++ /dev/null
@@ -1,7 +0,0 @@
-TclTLS @@VERS@@
-==========
-
-Release Date: @@DATE@@
-
-https://tcltls.rkeene.org/
-
Index: README.txt
==================================================================
--- README.txt
+++ README.txt
@@ -10,11 +10,11 @@
on any platform as it uses a generic mechanism for layering on SSL and Tcl.
Full filevent sematics should also be intact - see tests directory for
blocking and non-blocking examples.
-The current release is TLS 1.6, with binaries built against OpenSSL 0.9.8g.
+The current release is TLS 1.7, with binaries built against OpenSSL 1.1.1.
For best security and function, always compile from source with the latest
official release of OpenSSL (http://www.openssl.org/).
TLS 1.7 and newer require Tcl 8.4.0+, older versions may be used if older
versions of Tcl need to be used.
ADDED doc/tls.htm
Index: doc/tls.htm
==================================================================
--- /dev/null
+++ doc/tls.htm
@@ -0,0 +1,472 @@
+
+
+
+
+
+
+
+TLS (SSL) Tcl Commands
+
+
+
+
+
+ - NAME
+ - tls - binding to OpenSSL
+ toolkit.
+
+
+ - SYNOPSIS
+
+ - package require Tcl ?8.4?
+ - package require tls ?@@VERS@@?
+ -
+ - tls::init ?options?
+ - tls::socket ?options? host port
+ - tls::socket ?-server command?
+ ?options? port
+ - tls::handshake channel
+ - tls::status ?-local? channel
+ - tls::import channel ?options?
+ - tls::unimport channel
+ - tls::ciphers protocol ?verbose?
+ - tls::version
+
+ - COMMANDS
+ - CALLBACK OPTIONS
+ - HTTPS EXAMPLE
+ - SPECIAL CONSIDERATIONS
+ - SEE ALSO
+
+
+
+
+
+
+tls - binding to OpenSSL
+toolkit.
+
+
+
+package require Tcl 8.4
+package require tls @@VERS@@
+
+tls::init ?options?
+tls::socket ?options? host
+port
+tls::socket ?-server command? ?options? port
+tls::status ?-local? channel
+tls::handshake channel
+
+tls::import channel ?options?
+tls::unimport channel
+tls::ciphers
+protocol ?verbose?
+tls::version
+
+
+
+
+This extension provides a generic binding to OpenSSL, utilizing the
+Tcl_StackChannel
+API for Tcl 8.4 and higher. The sockets behave exactly the same
+as channels created using Tcl's built-in socket
+command with additional options for controlling the SSL session.
+
+
+
+
+Typically one would use the tls::socket command
+which provides compatibility with the native Tcl socket
+command. In such cases tls::import should not be
+used directly.
+
+
+ - tls::init ?options?
+ - This routine sets the default options used by tls::socket
+ and is optional. If you call tls::import
+ directly this routine has no effect. Any of the options
+ that tls::socket accepts can be set
+ using this command, though you should limit your options
+ to only TLS related ones.
+ -
+ - tls::socket ?options?
+ host port
+ - tls::socket ?-server command? ?options? port
+ - This is a helper function that utilizes the underlying
+ commands (tls::import). It behaves
+ exactly the same as the native Tcl socket
+ command except that the options can include any of the
+ applicable tls:import
+ options with one additional option:
+
+
+ - -autoservername bool
+ - Automatically send the -servername as the host argument
+ (default: false)
+
+
+ -
+ - tls::handshake channel
+ - Forces handshake to take place, and returns 0 if
+ handshake is still in progress (non-blocking), or 1 if
+ the handshake was successful. If the handshake failed
+ this routine will throw an error.
+ -
+ - tls::status
+ ?-local? channel
+ - Returns the current security status of an SSL channel. The
+ result is a list of key-value pairs describing the
+ connected peer. If the result is an empty list then the
+ SSL handshake has not yet completed.
+ If -local is given, then the certificate information
+ is the one used locally.
+
+
+
+
+ - issuer dn
+ - The distinguished name (DN) of the certificate
+ issuer.
+ - subject dn
+ - The distinguished name (DN) of the certificate
+ subject.
+ - notBefore date
+ - The begin date for the validity of the certificate.
+ - notAfter date
+ - The expiry date for the certificate.
+ - serial n
+ - The serial number of the certificate.
+ - cipher cipher
+ - The current cipher in use between the client and
+ server channels.
+ - sbits n
+ - The number of bits used for the session key.
+ - certificate cert
+ - The PEM encoded certificate.
+ - sha1_hash hash
+ - The SHA1 hash of the certificate.
+ - sha256_hash hash
+ - The SHA256 hash of the certificate.
+ - alpn protocol
+ - The protocol selected after Application-Layer Protocol
+ Negotiation (ALPN).
+ - version value
+ - The protocol version used for the connection:
+ SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, unknown
+
+
+
+
+ - tls::import channel
+ ?options?
+ - SSL-enable a regular Tcl channel - it need not be a
+ socket, but must provide bi-directional flow. Also
+ setting session parameters for SSL handshake.
+
+
+
+
+ - -alpn list
+ - List of protocols to offer during Application-Layer
+ Protocol Negotiation (ALPN). For example: h2, http/1.1, etc.
+ - -cadir dir
+ - Provide the directory containing the CA certificates. The
+ default directory is platform specific and can be set at
+ compile time. This can be overridden via the SSL_CERT_DIR
+ environment variable.
+ - -cafile filename
+ - Provide the CA file.
+ - -certfile filename
+ - Provide the name of a file containing certificate to use.
+ The default name is cert.pem. This can be overridden via the
+ SSL_CERT_FILE environment variable.
+ - -cert filename
+ - Provide the contents of a certificate to use, as a DER encoded binary value (X.509 DER).
+ - -cipher string
+ - Provide the cipher suites to use. Syntax is as per
+ OpenSSL.
+ - -command callback
+ - If specified, this callback will be invoked at several points
+ during the OpenSSL handshake. It can pass errors and tracing
+ information, and it can allow Tcl scripts to perform
+ their own validation of the certificate in place of the
+ default validation provided by OpenSSL.
+
+ See CALLBACK OPTIONS for
+ further discussion.
+ - -dhparams filename
+ - Provide a Diffie-Hellman parameters file.
+ - -keyfile filename
+ - Provide the private key file. (default:
+ value of -certfile)
+ - -key filename
+ - Provide the private key to use as a DER encoded value (PKCS#1 DER)
+ - -model channel
+ - This will force this channel to share the same SSL_CTX
+ structure as the specified channel, and
+ therefore share callbacks etc.
+ - -password callback
+ - If supplied, this callback will be invoked when OpenSSL needs
+ to obtain a password, typically to unlock the private key of
+ a certificate.
+ The callback should return a string which represents the
+ password to be used.
+
+ See CALLBACK OPTIONS for
+ further discussion.
+ - -request bool
+ - Request a certificate from peer during SSL handshake.
+ (default: true)
+ - -require bool
+ - Require a valid certificate from peer during SSL
+ handshake. If this is set to true then -request
+ must also be set to true. (default: false)
+ - -server bool
+ - Handshake as server if true, else handshake as
+ client.(default: false)
+ - -servername host
+ - Only available if the OpenSSL library the package is linked
+ against supports the TLS hostname extension for 'Server Name
+ Indication' (SNI). Use to name the logical host we are talking
+ to and expecting a certificate for
+ - -ssl2 bool
+ - Enable use of SSL v2. (default: false)
+ - -ssl3 bool
+ - Enable use of SSL v3. (default: false)
+ - -tls1 bool
+ - Enable use of TLS v1. (default: true)
+ - -tls1.1 bool
+ - Enable use of TLS v1.1 (default: true)
+ - -tls1.2 bool
+ - Enable use of TLS v1.2 (default: true)
+ - -tls1.3 bool
+ - Enable use of TLS v1.3 (default: true)
+
+
+
+
+ - tls::unimport channel
+ - Provided for symmetry to tls::import, this
+ unstacks the SSL-enabling of a regular Tcl channel. An error
+ is thrown if TLS is not the top stacked channel type.
+
+
+
+ - tls::ciphers
+ protocol ?verbose?
+ - Returns list of supported ciphers based on the protocol
+ you supply, which must be one of ssl2, ssl3, or tls1.
+ If verbose is specified as true then a verbose,
+ semi-human readable list is returned providing additional
+ information on the nature of the cipher support. In each
+ case the result is a Tcl list.
+
+
+
+ - tls::version
+ - Returns the version string defined by OpenSSL.
+
+
+
+
+
+As indicated above, individual channels can be given their own callbacks
+to handle intermediate processing by the OpenSSL library, using the
+-command and -password options passed to either of
+tls::socket or tls::import.
+
+
+
+
+
+ - -command callback
+ -
+ Invokes the specified callback script at
+ several points during the OpenSSL handshake.
+ Except as indicated below, values returned from the
+ callback are ignored.
+ Arguments appended to the script upon callback take one of the
+ following forms:
+
+
+
+
+
+
+
+
+ -
+ info channel major minor message
+
+ -
+ This form of callback is invoked by the OpenSSL function
+
SSL_CTX_set_info_callback().
+
+ The major and minor arguments are used to
+ represent the state information bitmask.
+
+ - Possible values for major are:
+ handshake, alert, connect, accept.- Possible values for minor are:
+ start, done, read, write, loop, exit.
+ The message argument is a descriptive string which may
+ be generated either by
+ SSL_state_string_long() or by
+ SSL_alert_desc_string_long(),
+ depending on context.
+
+
+
+
+ -
+ verify channel depth cert status error
+
+ -
+ This form of callback is invoked by the OpenSSL function
+
SSL_set_verify().
+
+ The depth argument is an integer representing the
+ current depth on the certificate chain, with
+ 0 as the subject certificate and higher values
+ denoting progressively more indirect issuer certificates.
+
+ The cert argument is a list of key-value pairs similar
+ to those returned by
+ tls::status.
+
+ The status argument is an integer representing the
+ current validity of the certificate.
+ A value of 0 means the certificate is deemed invalid.
+ A value of 1 means the certificate is deemed valid.
+
+ The error argument supplies the message, if any, generated
+ by
+ X509_STORE_CTX_get_error().
+
+
+ The callback may override normal validation processing by explicitly
+ returning one of the above status values.
+
+
+
+
+
+
+
+ - -password callback
+ -
+ Invokes the specified callback script when OpenSSL needs to
+ obtain a password. The callback should return a string which
+ represents the password to be used.
+ No arguments are appended to the script upon callback.
+
+
+
+
+
+Reference implementations of these callbacks are provided in the
+distribution as tls::callback and
+tls::password respectively. Note that these are
+sample implementations only. In a more realistic deployment
+you would specify your own callback scripts on each TLS channel
+using the -command and -password options.
+
+
+
+The default behavior when the -command option is not specified is for
+TLS to process the associated library callbacks internally.
+The default behavior when the -password option is not specified is for
+TLS to process the associated library callbacks by attempting to call
+tls::password.
+The difference between these two behaviors is a consequence of maintaining
+compatibility with earlier implementations.
+
+
+
+The tls::debug variable provides some additional
+control over these reference callbacks. Its value is zero by default.
+Higher values produce more diagnostic output, and will also force the
+verify method in tls::callback to accept the
+certificate, even when it is invalid.
+
+
+
+
+The use of the reference callbacks tls::callback and
+tls::password is not recommended. They may be removed
+from future releases.
+
+
+
+
+
+The use of the variable tls::debug is not recommended.
+It may be removed from future releases.
+
+
+
+
+
+TLS key logging can be enabled by setting the environment variable
+SSLKEYLOGFILE to the name of the file to log to. Then whenever TLS
+key material is generated or received it will be logged to the file.
+
+
+
+This example uses a sample server.pem provided with the TLS release,
+courtesy of the OpenSSL project.
+
+
+package require http
+package require tls
+
+http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
+
+set tok [http::geturl https://www.tcl.tk/]
+
+
+
+
+The capabilities of this package can vary enormously based
+upon how your OpenSSL library was configured and built. At the
+most macro-level OpenSSL supports a "no patents" build,
+which disables RSA, IDEA, RC(2,4,5) and SSL2 - if your OpenSSL is
+configured this way then you will need to build TLS with the
+-DNO_PATENTS option - and the resultant module will function
+correctly and also support ADH certificate-less encryption,
+however you will be unable to utilize this to speak to normal Web
+Servers, which typically require RSA support. Please see http://www.openssl.org/ for
+more information on the whole issue of patents and US export
+restrictions.
+
+
+
+socket, fileevent, OpenSSL
+
+
+
+
+Copyright © 1999 Matt Newman.
+Copyright © 2004 Starfish Systems.
+
+
+
DELETED gen_dh_params
Index: gen_dh_params
==================================================================
--- gen_dh_params
+++ /dev/null
@@ -1,280 +0,0 @@
-#! /usr/bin/env sh
-
-bits='2048'
-option_fallback='0'
-for arg in "$@"; do
- case "${arg}" in
- fallback)
- option_fallback='1'
- ;;
- bits=*)
- bits="`echo "${arg}" | cut -f 2 -d =`"
- ;;
- esac
-done
-
-openssl_dhparam() {
- if openssl dhparam -C "$@" | sed \
- -e 's/^\(static \)*DH \*get_dh[0-9]*/static DH *get_dhParams/' \
- -e '/^-----BEGIN DH PARAMETERS-----$/,/^-----END DH PARAMETERS-----$/ d;/^#/ d'
- then
- return 0
- fi
-
- return 1
-}
-
-gen_dh_params_openssl() {
- openssl_dhparam "${bits}" < /dev/null || return 1
- return 0
-}
-
-gen_dh_params_remote() {
- url="https://2ton.com.au/dhparam/${bits}"
-
- r_input="`curl -sS "${url}"`" || \
- r_input="`wget -O - -o /dev/null "${url}"`" || return 1
-
- if r_output="`echo "${r_input}" | openssl_dhparam`"; then
- echo "${r_output}"
-
- return 0
- fi
-
- return 1
-}
-
-gen_dh_params_fallback() {
- cat << \_EOF_
-DH *get_dhParams(void) {
- static unsigned char dhp[] = {
-_EOF_
- case "${bits}" in
- 2048)
- cat << \_EOF_
- 0xC1,0x51,0x58,0x69,0xFB,0xE8,0x6C,0x47,0x2B,0x86,0x61,0x4F,
- 0x20,0x2E,0xD3,0xFC,0x19,0xEE,0xB8,0xF3,0x35,0x7D,0xBA,0x86,
- 0x2A,0xC3,0xC8,0x6E,0xF4,0x99,0x75,0x65,0xD3,0x7A,0x9E,0xDF,
- 0xD4,0x1F,0x88,0xE3,0x17,0xFC,0xA1,0xED,0xA2,0xB6,0x77,0x84,
- 0xAA,0x08,0xF2,0x97,0x59,0x7A,0xA0,0x03,0x0D,0x3E,0x7E,0x6D,
- 0x65,0x6A,0xA4,0xEA,0x54,0xA9,0x52,0x5F,0x63,0xB4,0xBC,0x98,
- 0x4E,0xF6,0xE1,0xA4,0xEE,0x16,0x0A,0xB0,0x01,0xBD,0x9F,0xA1,
- 0xE8,0x23,0x29,0x56,0x40,0x95,0x13,0xEB,0xCB,0xD5,0xFC,0x76,
- 0x1A,0x41,0x26,0xCE,0x20,0xEB,0x30,0x10,0x17,0x07,0xE1,0x8C,
- 0xAC,0x57,0x37,0x8B,0xE8,0x01,0xDE,0xA9,0xEF,0xA4,0xC2,0xA4,
- 0x6E,0x48,0x25,0x11,0x33,0x11,0xD4,0x52,0x79,0x87,0x9F,0x75,
- 0x61,0xF7,0x9C,0x7D,0x36,0x41,0xCB,0xEC,0x8F,0xEA,0x4A,0x47,
- 0x6A,0x36,0x37,0x75,0xB9,0x8E,0xF5,0x5F,0x67,0xCF,0x1F,0xD8,
- 0xCA,0x70,0x42,0xC7,0xA2,0xED,0x0F,0x7D,0xBE,0x43,0x08,0x28,
- 0x66,0x3D,0xDD,0x87,0x0D,0x61,0x6E,0xD0,0xE7,0x49,0xD1,0x70,
- 0xA9,0x4D,0xD5,0xFD,0xED,0xF2,0x6D,0x32,0x17,0x97,0x5B,0x06,
- 0x60,0x9C,0x5F,0xA3,0x5D,0x34,0x14,0x7E,0x63,0x54,0xE4,0x7E,
- 0x09,0x8F,0xBB,0x8E,0xA0,0xD0,0x96,0xAC,0x30,0x20,0x39,0x3B,
- 0x8C,0x92,0x65,0x37,0x0A,0x8F,0xEC,0x72,0x8B,0x61,0x7D,0x62,
- 0x24,0x54,0xE9,0x1D,0x01,0x68,0x89,0xC4,0x7B,0x3C,0x48,0x62,
- 0x9B,0x83,0x11,0x3A,0x0B,0x0D,0xEF,0x5A,0xE4,0x7A,0xA0,0x69,
- 0xF4,0x54,0xB5,0x5B
-_EOF_
- ;;
- 4096)
- cat << \_EOF_
- 0xE3,0xA6,0x64,0x2D,0xE8,0x01,0xD0,0x81,0x67,0xCF,0x12,0x38,
- 0x5C,0x99,0x48,0x37,0xD7,0x0F,0x8D,0x10,0xEA,0x88,0x31,0x6D,
- 0xD4,0x69,0x10,0x57,0x94,0x8E,0xE8,0xF9,0x22,0xFE,0x0D,0x55,
- 0xC6,0x9D,0x29,0x7E,0x45,0x89,0xAA,0xD5,0x98,0xD2,0x98,0xFE,
- 0x03,0x54,0x5E,0x91,0x4C,0x4A,0xA7,0xFF,0x1F,0x2F,0x41,0x34,
- 0x03,0x9B,0x64,0x0A,0xFA,0x53,0xC7,0x45,0xD7,0x41,0x3F,0x16,
- 0xCD,0x40,0x9E,0xF2,0xC3,0xBD,0x49,0x2C,0x0C,0x35,0x9B,0x2F,
- 0x7D,0xA5,0x07,0x58,0xD1,0xFD,0xE9,0x6B,0x7A,0x54,0xA9,0xC2,
- 0xAC,0x09,0x7F,0x58,0xD5,0x52,0xB2,0x8A,0x5D,0xEC,0x41,0x23,
- 0x93,0xF4,0x05,0x8B,0x46,0x0E,0x46,0x46,0xC5,0xB4,0x75,0xCB,
- 0x1D,0x1D,0x6E,0x81,0xC5,0x55,0x24,0x1D,0x09,0x23,0xE2,0x3F,
- 0xF4,0x48,0x60,0xD7,0x95,0xC0,0x8B,0x71,0x11,0xA6,0x0B,0x04,
- 0x29,0xB6,0xAD,0xBF,0x05,0x6F,0x3B,0xB3,0x70,0x34,0xA5,0xF9,
- 0x14,0x81,0xD5,0xEA,0x3C,0x3C,0x38,0x44,0xCF,0x3D,0x32,0x29,
- 0x92,0xD5,0x1A,0x3C,0x25,0xB7,0x3D,0x42,0x17,0x96,0x8B,0xEE,
- 0xC3,0xE7,0x61,0x3A,0x51,0xC5,0x2A,0x51,0xBA,0x8F,0xD0,0x4C,
- 0x51,0x19,0xBE,0x35,0x1A,0x2E,0x9B,0x55,0x02,0xA7,0x5A,0xBF,
- 0xA2,0x00,0xF9,0xFF,0x4B,0xCA,0x76,0x25,0x3D,0x3B,0xB1,0x04,
- 0x9A,0x6D,0x7E,0x12,0xBB,0xBE,0x6A,0x5A,0xB2,0x87,0x8B,0xBC,
- 0xB9,0x7C,0x6A,0xE7,0x5E,0xC3,0x41,0x91,0x24,0xAD,0x5C,0xC7,
- 0x3F,0x24,0x77,0x17,0x53,0x9D,0x6A,0x5A,0x8E,0x39,0x00,0x1B,
- 0x49,0x93,0x07,0x6C,0x67,0xF3,0x1C,0x24,0x57,0x76,0x5E,0x78,
- 0xF1,0x8D,0x81,0xFF,0x81,0xD0,0x1B,0x7A,0x04,0xAC,0x7D,0x5B,
- 0x35,0x5F,0x45,0x25,0xAE,0x30,0x11,0x5B,0x34,0x17,0xE7,0x2D,
- 0x9D,0xE7,0x56,0x90,0x75,0x24,0x0C,0x01,0x84,0x38,0x1A,0x62,
- 0x55,0x43,0x66,0x21,0x29,0x44,0xE5,0x4B,0x90,0x9E,0x48,0x92,
- 0x0B,0x96,0x2A,0xD0,0xCD,0x3A,0xA4,0xBE,0xE7,0xDC,0xA3,0xFB,
- 0x0F,0xA3,0x9B,0xF7,0xA9,0x26,0x5A,0xCC,0x7F,0x4B,0x1A,0x5F,
- 0xD6,0x32,0xA9,0x71,0xA1,0x10,0xE5,0x7C,0x4F,0x59,0xFE,0x3D,
- 0x60,0x41,0x0A,0xA7,0x68,0x60,0x1E,0xDE,0x6E,0xF7,0x71,0x4D,
- 0xBE,0xC8,0x49,0xF8,0x57,0x7C,0x99,0x6E,0x59,0x32,0xF8,0x26,
- 0xF1,0x25,0x94,0xC5,0xDA,0x78,0xBB,0x48,0x97,0xE8,0xDF,0x70,
- 0x05,0x86,0xE2,0xE7,0x35,0xD7,0x3F,0x23,0x18,0xAA,0x86,0x53,
- 0x6B,0x0D,0xEC,0x93,0x89,0xA4,0xD0,0xDA,0xE3,0xDD,0x11,0x06,
- 0xCE,0xDD,0x4D,0xD3,0xBF,0x9A,0x71,0x5E,0xA7,0x39,0x9A,0x31,
- 0x4B,0x56,0xB3,0x22,0x1B,0x81,0xDC,0xBE,0x0E,0x7B,0x8A,0xAA,
- 0x37,0x61,0xED,0x4D,0xEE,0x1A,0xC3,0x54,0xBC,0x4F,0x0E,0x61,
- 0x38,0x00,0xAA,0x45,0x18,0xC2,0xDF,0xA5,0x3D,0x75,0x98,0x16,
- 0xBB,0x0A,0x39,0x9A,0xFE,0x1F,0x53,0xAD,0xC3,0xEA,0xDF,0xC6,
- 0x3D,0xD5,0xBA,0xC8,0xF3,0x03,0x3A,0x3B,0x8D,0x03,0x84,0xCD,
- 0x86,0xED,0x42,0xDB,0xD8,0xE0,0xC1,0xAF,0xB1,0xDD,0xB5,0x35,
- 0x28,0xB1,0x02,0xE2,0x9B,0x12,0x2E,0x12,0x02,0x1C,0x7D,0x3B,
- 0x3B,0x8D,0xAF,0x9D,0x3F,0xD6,0xE0,0x53
-_EOF_
- ;;
- 8192)
- cat << \_EOF_
- 0x9C,0xC3,0x9C,0x6C,0x61,0xC5,0xFA,0x32,0xB8,0x86,0x5A,0x38,
- 0xED,0x46,0x5C,0x81,0x08,0xD9,0x69,0x11,0x44,0x50,0x97,0x4D,
- 0xCB,0x09,0xFC,0xD1,0x68,0x9F,0x4E,0x96,0x10,0xFF,0xDA,0xD7,
- 0xA3,0xC9,0x74,0xE9,0xBA,0xDB,0x6B,0x04,0xB8,0xBF,0xF4,0x72,
- 0x6D,0x18,0xB1,0xF4,0x9A,0x77,0xA9,0x94,0xE8,0x13,0xF7,0x1D,
- 0x92,0x12,0x7B,0xB9,0x92,0x71,0x54,0x83,0x73,0x71,0xF6,0xA7,
- 0x12,0xEC,0x62,0xB8,0xDC,0xA1,0x2E,0x00,0x88,0x53,0xF3,0x01,
- 0xAF,0x52,0xF7,0xBB,0xE1,0x7B,0xF1,0x2A,0xD9,0xEF,0x21,0xD4,
- 0x88,0x18,0xEC,0x98,0x72,0x05,0x60,0xEC,0x5A,0x1C,0x2D,0x0D,
- 0x43,0x5D,0x19,0xD6,0x1D,0xD2,0x3C,0x8E,0xD3,0x43,0x62,0x6C,
- 0x32,0x14,0x40,0xD6,0xBE,0xE7,0x84,0x6E,0x76,0xA5,0x90,0x14,
- 0xC8,0x40,0xA3,0x2E,0x6A,0x3D,0x3B,0x43,0x5D,0xB1,0x3F,0x5F,
- 0x6E,0xD5,0x1B,0xE0,0x20,0x82,0x8A,0xEE,0xC5,0x65,0x05,0x62,
- 0xB5,0x96,0xEE,0x27,0xF1,0xF3,0x32,0xE4,0x00,0x7D,0x6A,0x6C,
- 0x45,0x05,0x00,0x4A,0x9C,0x9D,0xB9,0x19,0x77,0xC5,0x31,0xEE,
- 0x6E,0x30,0x54,0x0D,0x08,0xFF,0x19,0xC4,0x34,0xD7,0x9F,0xC9,
- 0x5B,0x89,0x22,0x4E,0xC0,0xBF,0x16,0x3E,0x10,0xBB,0x58,0xBA,
- 0x31,0x5C,0xDC,0xD3,0xD9,0xFF,0x73,0xD9,0x29,0x66,0x4A,0xE6,
- 0xB0,0xBA,0x4B,0x1A,0x3C,0x5E,0xA7,0x19,0x19,0xD8,0x84,0xD2,
- 0x54,0x47,0x86,0xE3,0xCA,0xF7,0x8A,0xC9,0xDB,0x3A,0x5A,0xB7,
- 0xB7,0xA4,0x27,0x57,0x53,0x34,0x9D,0xF2,0xF2,0x26,0x0D,0xAC,
- 0xC5,0xFA,0xE9,0x9A,0xC5,0xDA,0x9D,0xA3,0x2E,0x40,0x85,0x92,
- 0xF4,0x2F,0xEA,0xF7,0xA4,0x6F,0x36,0x36,0x41,0xFA,0x41,0x5B,
- 0x02,0x4E,0xFC,0xDF,0xBB,0x5F,0x74,0x7B,0xFF,0x81,0xEB,0x60,
- 0x08,0x55,0x91,0xBF,0x0C,0x1E,0x80,0xB3,0xC3,0x39,0x5A,0x5D,
- 0x08,0x3E,0x3C,0xB8,0x76,0xE1,0x92,0x37,0xF1,0xCC,0x0C,0x3F,
- 0x46,0xED,0x51,0x2D,0x6F,0x57,0x05,0x47,0x78,0xB5,0xF1,0x6B,
- 0x7C,0xEA,0x51,0xA6,0x88,0xD8,0x63,0x18,0x8E,0x42,0x0E,0x50,
- 0xF1,0xAC,0xD0,0x75,0x0A,0xB5,0x9B,0xD5,0x07,0x3A,0xF0,0x75,
- 0x04,0x27,0xC5,0xBD,0xA6,0xAE,0x18,0xEE,0x30,0x22,0x70,0x56,
- 0x09,0xA7,0xC2,0x26,0x61,0x3B,0x56,0x27,0x82,0x97,0xF6,0xFE,
- 0x7A,0x3D,0x17,0x3C,0xC2,0x27,0x39,0xD3,0xBB,0x80,0xB6,0x42,
- 0x4D,0x20,0xB1,0xC1,0x89,0x00,0x77,0x8C,0x6F,0xDD,0x6F,0x1D,
- 0x44,0xAD,0x1B,0x92,0x6F,0xD6,0x56,0x11,0x6E,0x12,0x5C,0x7F,
- 0x69,0x33,0x17,0x7A,0x20,0xE8,0x5D,0x81,0xC0,0xDD,0x1E,0xBE,
- 0xEF,0x62,0x81,0xF2,0xEA,0xEA,0xDE,0x7B,0xA1,0x8C,0x7D,0x91,
- 0x8B,0x62,0xBD,0x13,0x53,0x41,0xB9,0x45,0x65,0x11,0xB0,0x00,
- 0x7C,0xA6,0x12,0x19,0xDC,0x77,0x26,0xD6,0x13,0xC8,0xDF,0x47,
- 0x7A,0xCE,0xEB,0xD8,0xC3,0xDF,0x7F,0x21,0x27,0x5C,0x4A,0x6B,
- 0xE9,0x27,0xC7,0x60,0x56,0x6E,0xA2,0x5F,0xF2,0xAD,0xB0,0xC3,
- 0x97,0xF6,0xE9,0xDF,0xFB,0x1F,0xE9,0x17,0x06,0x36,0xC5,0x10,
- 0xC0,0x49,0xD5,0x59,0xEA,0x97,0x27,0xE7,0x43,0x64,0xDE,0x31,
- 0xD7,0x14,0x9D,0xDC,0x78,0xC5,0x0E,0xEF,0x6A,0x76,0x57,0x33,
- 0xAF,0x54,0xB1,0x30,0xD0,0x91,0x24,0x09,0x24,0x40,0xD5,0x00,
- 0x9B,0x84,0xF7,0xFC,0xAD,0x7F,0x41,0xBB,0x00,0x84,0x49,0x49,
- 0xA1,0x43,0x44,0xA0,0xA3,0xD1,0xBA,0x49,0xD8,0xCE,0x60,0x90,
- 0x07,0x20,0xCD,0xC8,0xEB,0xD4,0x02,0x71,0xB8,0x60,0xDF,0xA9,
- 0x6B,0xEC,0x25,0x8D,0x71,0x28,0x6A,0x2E,0xF6,0x52,0xF0,0x24,
- 0xF3,0xF5,0x1E,0x00,0x7B,0x7C,0xCA,0x6A,0x6B,0xD7,0x4F,0x3E,
- 0x5E,0x4B,0x85,0xCF,0xF1,0x67,0x9F,0x89,0x5A,0xF4,0x3A,0x29,
- 0x73,0xFF,0xDC,0x68,0x25,0xA5,0x60,0x10,0xFC,0x9A,0x73,0x78,
- 0xEA,0x28,0xC1,0x11,0x3B,0x07,0x46,0xEB,0xDE,0xF1,0xF3,0x2E,
- 0xC7,0xC1,0x24,0xFB,0xC2,0x6C,0x4A,0x38,0x6C,0x9A,0x7F,0x87,
- 0x76,0x30,0xF4,0xCC,0x21,0x49,0xC1,0x66,0x3D,0x95,0xE4,0xAA,
- 0xE2,0x75,0x08,0xAB,0xEF,0xA2,0x51,0x30,0xFE,0x86,0xD0,0xE1,
- 0x4C,0x05,0x0C,0xDE,0x63,0x93,0xB3,0x37,0x11,0x81,0xB5,0x8F,
- 0x84,0xE2,0x48,0xC1,0xF6,0xF6,0xD6,0x50,0x91,0xDE,0x61,0x14,
- 0x7B,0x6E,0x88,0x95,0x30,0x52,0xEF,0xA5,0x03,0x99,0xBE,0x50,
- 0x97,0xE3,0x25,0x8F,0x50,0x01,0x9C,0x54,0x99,0x2E,0x4C,0x6A,
- 0x61,0xD7,0x0D,0xB9,0xFE,0xE9,0xFC,0x37,0xC1,0x6A,0xDF,0x84,
- 0xF4,0x5A,0x7E,0xBA,0x95,0x23,0x5C,0x41,0x35,0xDB,0xF9,0x1E,
- 0x93,0xC6,0x29,0x8E,0x57,0x28,0x3D,0x3A,0xDE,0x31,0x86,0x69,
- 0x3D,0xC3,0x8F,0x27,0x62,0x84,0x77,0x58,0x02,0x7F,0x90,0x76,
- 0x2D,0xDF,0x45,0x70,0x3F,0x04,0x44,0x5C,0xD1,0x8C,0x73,0x5E,
- 0xB5,0xC8,0x9A,0x72,0x3E,0xA9,0x4D,0xFC,0xDC,0xAC,0x7B,0xFF,
- 0x54,0xC2,0x7B,0x3B,0x11,0x6B,0x14,0xA3,0x50,0xDB,0x14,0xB0,
- 0x89,0x5A,0xE7,0xDD,0xBF,0x1E,0x27,0xBC,0xC6,0x30,0xC4,0xD6,
- 0x74,0x13,0x26,0xBA,0x67,0x15,0x56,0x42,0xED,0xDA,0xFF,0x9F,
- 0x4B,0xBE,0x3E,0xBC,0xD0,0xA8,0xCA,0xB1,0x8E,0xB7,0xD0,0xFF,
- 0xE0,0x87,0x67,0xE4,0x51,0xA4,0xB9,0xF3,0x47,0xFA,0x13,0xFA,
- 0xB1,0xDA,0xB6,0xF8,0xEC,0x6D,0x0B,0x2E,0x99,0x37,0xB8,0x66,
- 0x80,0x83,0x3A,0xCA,0x46,0x6D,0xDC,0x24,0x9F,0x83,0x54,0xA9,
- 0x70,0x62,0x21,0x6D,0x28,0x0E,0x63,0x8B,0x91,0x7F,0xFF,0xCD,
- 0x80,0xF5,0xAC,0xE6,0x90,0x97,0x3C,0xB5,0xE8,0x00,0x90,0x96,
- 0xB7,0x26,0x2C,0xB2,0x9C,0xEF,0xBF,0xCC,0xD6,0xA8,0x01,0xA0,
- 0xFC,0x20,0x61,0xBD,0xA9,0xEE,0x5F,0x8B,0x32,0x1C,0x62,0xF0,
- 0x94,0x81,0x86,0x30,0x1B,0xB1,0x12,0xF5,0x58,0x52,0x8D,0xE4,
- 0x99,0x43,0x60,0x9B,0x24,0xF8,0x8B,0x14,0x63,0x0C,0x93,0xF4,
- 0x7A,0x70,0x0A,0xE1,0x45,0x16,0x92,0x9D,0x12,0x50,0x05,0x3C,
- 0x05,0xEE,0x40,0x32,0x4D,0x99,0xFF,0xF6,0x14,0x25,0xF6,0xDF,
- 0xD8,0xDA,0xE0,0x85,0x1B,0x3F,0x2C,0x50,0xD9,0x01,0x4B,0x01,
- 0x65,0x2C,0x75,0x32,0xBA,0x6F,0x00,0x56,0xD3,0x83,0xC8,0x44,
- 0x9B,0x62,0x3F,0x88,0xA7,0x18,0xAC,0x69,0xBB,0xF3,0x14,0xD3,
- 0xA4,0x09,0x6C,0x4A,0x14,0x0C,0x55,0x95,0x7A,0x33,0x21,0x99,
- 0x0F,0x01,0x00,0x5D,0x2D,0xAB,0xEB,0x7A,0x76,0x03,0xE7,0x2A,
- 0x1D,0xC2,0x86,0x4B
-_EOF_
- ;;
- *)
- return 1
- ;;
- esac
-
- cat << \_EOF_
- };
- static unsigned char dhg[] = {
- 0x02,
- };
-
- DH *dh = DH_new();;
- BIGNUM *dhp_bn, *dhg_bn;
-
- if (dh == NULL) {
- return NULL;
- }
-
- dhp_bn = BN_bin2bn(dhp, sizeof (dhp), NULL);
- dhg_bn = BN_bin2bn(dhg, sizeof (dhg), NULL);
-
-#ifdef TCLTLS_OPENSSL_PRE_1_1_API
- dh->p = dhp_bn;
- dh->g = dhg_bn;
-
- if (dhp_bn == NULL || dhg_bn == NULL) {
-#else
- if (dhp_bn == NULL || dhg_bn == NULL || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) {
-#endif
- DH_free(dh);
- BN_free(dhp_bn);
- BN_free(dhg_bn);
- return(NULL);
- }
-
- return(dh);
-}
-_EOF_
-
- return 0
-}
-
-# Enable support for giving the same DH params each time
-if [ "${option_fallback}" = '1' ]; then
- gen_dh_params_fallback && exit 0
-
- echo "Unable to generate fallback parameters for DH of ${bits} bits" >&2
-
- exit 1
-fi
-
-echo "*****************************" >&2
-echo "** Generating DH Primes. **" >&2
-echo "** This will take a while. **" >&2
-echo "*****************************" >&2
-echo "Use OpenSSL" >&2
-gen_dh_params_openssl && exit 0
-echo "Use Remote" >&2
-gen_dh_params_remote && exit 0
-echo "Use fallback" >&2
-gen_dh_params_fallback && exit 0
-
-echo "Unable to generate parameters for DH of ${bits} bits" >&2
-
-exit 1
ADDED generic/HEADER
Index: generic/HEADER
==================================================================
--- /dev/null
+++ generic/HEADER
@@ -0,0 +1,7 @@
+TclTLS @@VERS@@
+==========
+
+Release Date: @@DATE@@
+
+https://tcltls.rkeene.org/
+
ADDED generic/gen_dh_params
Index: generic/gen_dh_params
==================================================================
--- /dev/null
+++ generic/gen_dh_params
@@ -0,0 +1,280 @@
+#! /usr/bin/env sh
+
+bits='2048'
+option_fallback='0'
+for arg in "$@"; do
+ case "${arg}" in
+ fallback)
+ option_fallback='1'
+ ;;
+ bits=*)
+ bits="`echo "${arg}" | cut -f 2 -d =`"
+ ;;
+ esac
+done
+
+openssl_dhparam() {
+ if openssl dhparam -C "$@" | sed \
+ -e 's/^\(static \)*DH \*get_dh[0-9]*/static DH *get_dhParams/' \
+ -e '/^-----BEGIN DH PARAMETERS-----$/,/^-----END DH PARAMETERS-----$/ d;/^#/ d'
+ then
+ return 0
+ fi
+
+ return 1
+}
+
+gen_dh_params_openssl() {
+ openssl_dhparam "${bits}" < /dev/null || return 1
+ return 0
+}
+
+gen_dh_params_remote() {
+ url="https://2ton.com.au/dhparam/${bits}"
+
+ r_input="`curl -sS "${url}"`" || \
+ r_input="`wget -O - -o /dev/null "${url}"`" || return 1
+
+ if r_output="`echo "${r_input}" | openssl_dhparam`"; then
+ echo "${r_output}"
+
+ return 0
+ fi
+
+ return 1
+}
+
+gen_dh_params_fallback() {
+ cat << \_EOF_
+DH *get_dhParams(void) {
+ static unsigned char dhp[] = {
+_EOF_
+ case "${bits}" in
+ 2048)
+ cat << \_EOF_
+ 0xC1,0x51,0x58,0x69,0xFB,0xE8,0x6C,0x47,0x2B,0x86,0x61,0x4F,
+ 0x20,0x2E,0xD3,0xFC,0x19,0xEE,0xB8,0xF3,0x35,0x7D,0xBA,0x86,
+ 0x2A,0xC3,0xC8,0x6E,0xF4,0x99,0x75,0x65,0xD3,0x7A,0x9E,0xDF,
+ 0xD4,0x1F,0x88,0xE3,0x17,0xFC,0xA1,0xED,0xA2,0xB6,0x77,0x84,
+ 0xAA,0x08,0xF2,0x97,0x59,0x7A,0xA0,0x03,0x0D,0x3E,0x7E,0x6D,
+ 0x65,0x6A,0xA4,0xEA,0x54,0xA9,0x52,0x5F,0x63,0xB4,0xBC,0x98,
+ 0x4E,0xF6,0xE1,0xA4,0xEE,0x16,0x0A,0xB0,0x01,0xBD,0x9F,0xA1,
+ 0xE8,0x23,0x29,0x56,0x40,0x95,0x13,0xEB,0xCB,0xD5,0xFC,0x76,
+ 0x1A,0x41,0x26,0xCE,0x20,0xEB,0x30,0x10,0x17,0x07,0xE1,0x8C,
+ 0xAC,0x57,0x37,0x8B,0xE8,0x01,0xDE,0xA9,0xEF,0xA4,0xC2,0xA4,
+ 0x6E,0x48,0x25,0x11,0x33,0x11,0xD4,0x52,0x79,0x87,0x9F,0x75,
+ 0x61,0xF7,0x9C,0x7D,0x36,0x41,0xCB,0xEC,0x8F,0xEA,0x4A,0x47,
+ 0x6A,0x36,0x37,0x75,0xB9,0x8E,0xF5,0x5F,0x67,0xCF,0x1F,0xD8,
+ 0xCA,0x70,0x42,0xC7,0xA2,0xED,0x0F,0x7D,0xBE,0x43,0x08,0x28,
+ 0x66,0x3D,0xDD,0x87,0x0D,0x61,0x6E,0xD0,0xE7,0x49,0xD1,0x70,
+ 0xA9,0x4D,0xD5,0xFD,0xED,0xF2,0x6D,0x32,0x17,0x97,0x5B,0x06,
+ 0x60,0x9C,0x5F,0xA3,0x5D,0x34,0x14,0x7E,0x63,0x54,0xE4,0x7E,
+ 0x09,0x8F,0xBB,0x8E,0xA0,0xD0,0x96,0xAC,0x30,0x20,0x39,0x3B,
+ 0x8C,0x92,0x65,0x37,0x0A,0x8F,0xEC,0x72,0x8B,0x61,0x7D,0x62,
+ 0x24,0x54,0xE9,0x1D,0x01,0x68,0x89,0xC4,0x7B,0x3C,0x48,0x62,
+ 0x9B,0x83,0x11,0x3A,0x0B,0x0D,0xEF,0x5A,0xE4,0x7A,0xA0,0x69,
+ 0xF4,0x54,0xB5,0x5B
+_EOF_
+ ;;
+ 4096)
+ cat << \_EOF_
+ 0xE3,0xA6,0x64,0x2D,0xE8,0x01,0xD0,0x81,0x67,0xCF,0x12,0x38,
+ 0x5C,0x99,0x48,0x37,0xD7,0x0F,0x8D,0x10,0xEA,0x88,0x31,0x6D,
+ 0xD4,0x69,0x10,0x57,0x94,0x8E,0xE8,0xF9,0x22,0xFE,0x0D,0x55,
+ 0xC6,0x9D,0x29,0x7E,0x45,0x89,0xAA,0xD5,0x98,0xD2,0x98,0xFE,
+ 0x03,0x54,0x5E,0x91,0x4C,0x4A,0xA7,0xFF,0x1F,0x2F,0x41,0x34,
+ 0x03,0x9B,0x64,0x0A,0xFA,0x53,0xC7,0x45,0xD7,0x41,0x3F,0x16,
+ 0xCD,0x40,0x9E,0xF2,0xC3,0xBD,0x49,0x2C,0x0C,0x35,0x9B,0x2F,
+ 0x7D,0xA5,0x07,0x58,0xD1,0xFD,0xE9,0x6B,0x7A,0x54,0xA9,0xC2,
+ 0xAC,0x09,0x7F,0x58,0xD5,0x52,0xB2,0x8A,0x5D,0xEC,0x41,0x23,
+ 0x93,0xF4,0x05,0x8B,0x46,0x0E,0x46,0x46,0xC5,0xB4,0x75,0xCB,
+ 0x1D,0x1D,0x6E,0x81,0xC5,0x55,0x24,0x1D,0x09,0x23,0xE2,0x3F,
+ 0xF4,0x48,0x60,0xD7,0x95,0xC0,0x8B,0x71,0x11,0xA6,0x0B,0x04,
+ 0x29,0xB6,0xAD,0xBF,0x05,0x6F,0x3B,0xB3,0x70,0x34,0xA5,0xF9,
+ 0x14,0x81,0xD5,0xEA,0x3C,0x3C,0x38,0x44,0xCF,0x3D,0x32,0x29,
+ 0x92,0xD5,0x1A,0x3C,0x25,0xB7,0x3D,0x42,0x17,0x96,0x8B,0xEE,
+ 0xC3,0xE7,0x61,0x3A,0x51,0xC5,0x2A,0x51,0xBA,0x8F,0xD0,0x4C,
+ 0x51,0x19,0xBE,0x35,0x1A,0x2E,0x9B,0x55,0x02,0xA7,0x5A,0xBF,
+ 0xA2,0x00,0xF9,0xFF,0x4B,0xCA,0x76,0x25,0x3D,0x3B,0xB1,0x04,
+ 0x9A,0x6D,0x7E,0x12,0xBB,0xBE,0x6A,0x5A,0xB2,0x87,0x8B,0xBC,
+ 0xB9,0x7C,0x6A,0xE7,0x5E,0xC3,0x41,0x91,0x24,0xAD,0x5C,0xC7,
+ 0x3F,0x24,0x77,0x17,0x53,0x9D,0x6A,0x5A,0x8E,0x39,0x00,0x1B,
+ 0x49,0x93,0x07,0x6C,0x67,0xF3,0x1C,0x24,0x57,0x76,0x5E,0x78,
+ 0xF1,0x8D,0x81,0xFF,0x81,0xD0,0x1B,0x7A,0x04,0xAC,0x7D,0x5B,
+ 0x35,0x5F,0x45,0x25,0xAE,0x30,0x11,0x5B,0x34,0x17,0xE7,0x2D,
+ 0x9D,0xE7,0x56,0x90,0x75,0x24,0x0C,0x01,0x84,0x38,0x1A,0x62,
+ 0x55,0x43,0x66,0x21,0x29,0x44,0xE5,0x4B,0x90,0x9E,0x48,0x92,
+ 0x0B,0x96,0x2A,0xD0,0xCD,0x3A,0xA4,0xBE,0xE7,0xDC,0xA3,0xFB,
+ 0x0F,0xA3,0x9B,0xF7,0xA9,0x26,0x5A,0xCC,0x7F,0x4B,0x1A,0x5F,
+ 0xD6,0x32,0xA9,0x71,0xA1,0x10,0xE5,0x7C,0x4F,0x59,0xFE,0x3D,
+ 0x60,0x41,0x0A,0xA7,0x68,0x60,0x1E,0xDE,0x6E,0xF7,0x71,0x4D,
+ 0xBE,0xC8,0x49,0xF8,0x57,0x7C,0x99,0x6E,0x59,0x32,0xF8,0x26,
+ 0xF1,0x25,0x94,0xC5,0xDA,0x78,0xBB,0x48,0x97,0xE8,0xDF,0x70,
+ 0x05,0x86,0xE2,0xE7,0x35,0xD7,0x3F,0x23,0x18,0xAA,0x86,0x53,
+ 0x6B,0x0D,0xEC,0x93,0x89,0xA4,0xD0,0xDA,0xE3,0xDD,0x11,0x06,
+ 0xCE,0xDD,0x4D,0xD3,0xBF,0x9A,0x71,0x5E,0xA7,0x39,0x9A,0x31,
+ 0x4B,0x56,0xB3,0x22,0x1B,0x81,0xDC,0xBE,0x0E,0x7B,0x8A,0xAA,
+ 0x37,0x61,0xED,0x4D,0xEE,0x1A,0xC3,0x54,0xBC,0x4F,0x0E,0x61,
+ 0x38,0x00,0xAA,0x45,0x18,0xC2,0xDF,0xA5,0x3D,0x75,0x98,0x16,
+ 0xBB,0x0A,0x39,0x9A,0xFE,0x1F,0x53,0xAD,0xC3,0xEA,0xDF,0xC6,
+ 0x3D,0xD5,0xBA,0xC8,0xF3,0x03,0x3A,0x3B,0x8D,0x03,0x84,0xCD,
+ 0x86,0xED,0x42,0xDB,0xD8,0xE0,0xC1,0xAF,0xB1,0xDD,0xB5,0x35,
+ 0x28,0xB1,0x02,0xE2,0x9B,0x12,0x2E,0x12,0x02,0x1C,0x7D,0x3B,
+ 0x3B,0x8D,0xAF,0x9D,0x3F,0xD6,0xE0,0x53
+_EOF_
+ ;;
+ 8192)
+ cat << \_EOF_
+ 0x9C,0xC3,0x9C,0x6C,0x61,0xC5,0xFA,0x32,0xB8,0x86,0x5A,0x38,
+ 0xED,0x46,0x5C,0x81,0x08,0xD9,0x69,0x11,0x44,0x50,0x97,0x4D,
+ 0xCB,0x09,0xFC,0xD1,0x68,0x9F,0x4E,0x96,0x10,0xFF,0xDA,0xD7,
+ 0xA3,0xC9,0x74,0xE9,0xBA,0xDB,0x6B,0x04,0xB8,0xBF,0xF4,0x72,
+ 0x6D,0x18,0xB1,0xF4,0x9A,0x77,0xA9,0x94,0xE8,0x13,0xF7,0x1D,
+ 0x92,0x12,0x7B,0xB9,0x92,0x71,0x54,0x83,0x73,0x71,0xF6,0xA7,
+ 0x12,0xEC,0x62,0xB8,0xDC,0xA1,0x2E,0x00,0x88,0x53,0xF3,0x01,
+ 0xAF,0x52,0xF7,0xBB,0xE1,0x7B,0xF1,0x2A,0xD9,0xEF,0x21,0xD4,
+ 0x88,0x18,0xEC,0x98,0x72,0x05,0x60,0xEC,0x5A,0x1C,0x2D,0x0D,
+ 0x43,0x5D,0x19,0xD6,0x1D,0xD2,0x3C,0x8E,0xD3,0x43,0x62,0x6C,
+ 0x32,0x14,0x40,0xD6,0xBE,0xE7,0x84,0x6E,0x76,0xA5,0x90,0x14,
+ 0xC8,0x40,0xA3,0x2E,0x6A,0x3D,0x3B,0x43,0x5D,0xB1,0x3F,0x5F,
+ 0x6E,0xD5,0x1B,0xE0,0x20,0x82,0x8A,0xEE,0xC5,0x65,0x05,0x62,
+ 0xB5,0x96,0xEE,0x27,0xF1,0xF3,0x32,0xE4,0x00,0x7D,0x6A,0x6C,
+ 0x45,0x05,0x00,0x4A,0x9C,0x9D,0xB9,0x19,0x77,0xC5,0x31,0xEE,
+ 0x6E,0x30,0x54,0x0D,0x08,0xFF,0x19,0xC4,0x34,0xD7,0x9F,0xC9,
+ 0x5B,0x89,0x22,0x4E,0xC0,0xBF,0x16,0x3E,0x10,0xBB,0x58,0xBA,
+ 0x31,0x5C,0xDC,0xD3,0xD9,0xFF,0x73,0xD9,0x29,0x66,0x4A,0xE6,
+ 0xB0,0xBA,0x4B,0x1A,0x3C,0x5E,0xA7,0x19,0x19,0xD8,0x84,0xD2,
+ 0x54,0x47,0x86,0xE3,0xCA,0xF7,0x8A,0xC9,0xDB,0x3A,0x5A,0xB7,
+ 0xB7,0xA4,0x27,0x57,0x53,0x34,0x9D,0xF2,0xF2,0x26,0x0D,0xAC,
+ 0xC5,0xFA,0xE9,0x9A,0xC5,0xDA,0x9D,0xA3,0x2E,0x40,0x85,0x92,
+ 0xF4,0x2F,0xEA,0xF7,0xA4,0x6F,0x36,0x36,0x41,0xFA,0x41,0x5B,
+ 0x02,0x4E,0xFC,0xDF,0xBB,0x5F,0x74,0x7B,0xFF,0x81,0xEB,0x60,
+ 0x08,0x55,0x91,0xBF,0x0C,0x1E,0x80,0xB3,0xC3,0x39,0x5A,0x5D,
+ 0x08,0x3E,0x3C,0xB8,0x76,0xE1,0x92,0x37,0xF1,0xCC,0x0C,0x3F,
+ 0x46,0xED,0x51,0x2D,0x6F,0x57,0x05,0x47,0x78,0xB5,0xF1,0x6B,
+ 0x7C,0xEA,0x51,0xA6,0x88,0xD8,0x63,0x18,0x8E,0x42,0x0E,0x50,
+ 0xF1,0xAC,0xD0,0x75,0x0A,0xB5,0x9B,0xD5,0x07,0x3A,0xF0,0x75,
+ 0x04,0x27,0xC5,0xBD,0xA6,0xAE,0x18,0xEE,0x30,0x22,0x70,0x56,
+ 0x09,0xA7,0xC2,0x26,0x61,0x3B,0x56,0x27,0x82,0x97,0xF6,0xFE,
+ 0x7A,0x3D,0x17,0x3C,0xC2,0x27,0x39,0xD3,0xBB,0x80,0xB6,0x42,
+ 0x4D,0x20,0xB1,0xC1,0x89,0x00,0x77,0x8C,0x6F,0xDD,0x6F,0x1D,
+ 0x44,0xAD,0x1B,0x92,0x6F,0xD6,0x56,0x11,0x6E,0x12,0x5C,0x7F,
+ 0x69,0x33,0x17,0x7A,0x20,0xE8,0x5D,0x81,0xC0,0xDD,0x1E,0xBE,
+ 0xEF,0x62,0x81,0xF2,0xEA,0xEA,0xDE,0x7B,0xA1,0x8C,0x7D,0x91,
+ 0x8B,0x62,0xBD,0x13,0x53,0x41,0xB9,0x45,0x65,0x11,0xB0,0x00,
+ 0x7C,0xA6,0x12,0x19,0xDC,0x77,0x26,0xD6,0x13,0xC8,0xDF,0x47,
+ 0x7A,0xCE,0xEB,0xD8,0xC3,0xDF,0x7F,0x21,0x27,0x5C,0x4A,0x6B,
+ 0xE9,0x27,0xC7,0x60,0x56,0x6E,0xA2,0x5F,0xF2,0xAD,0xB0,0xC3,
+ 0x97,0xF6,0xE9,0xDF,0xFB,0x1F,0xE9,0x17,0x06,0x36,0xC5,0x10,
+ 0xC0,0x49,0xD5,0x59,0xEA,0x97,0x27,0xE7,0x43,0x64,0xDE,0x31,
+ 0xD7,0x14,0x9D,0xDC,0x78,0xC5,0x0E,0xEF,0x6A,0x76,0x57,0x33,
+ 0xAF,0x54,0xB1,0x30,0xD0,0x91,0x24,0x09,0x24,0x40,0xD5,0x00,
+ 0x9B,0x84,0xF7,0xFC,0xAD,0x7F,0x41,0xBB,0x00,0x84,0x49,0x49,
+ 0xA1,0x43,0x44,0xA0,0xA3,0xD1,0xBA,0x49,0xD8,0xCE,0x60,0x90,
+ 0x07,0x20,0xCD,0xC8,0xEB,0xD4,0x02,0x71,0xB8,0x60,0xDF,0xA9,
+ 0x6B,0xEC,0x25,0x8D,0x71,0x28,0x6A,0x2E,0xF6,0x52,0xF0,0x24,
+ 0xF3,0xF5,0x1E,0x00,0x7B,0x7C,0xCA,0x6A,0x6B,0xD7,0x4F,0x3E,
+ 0x5E,0x4B,0x85,0xCF,0xF1,0x67,0x9F,0x89,0x5A,0xF4,0x3A,0x29,
+ 0x73,0xFF,0xDC,0x68,0x25,0xA5,0x60,0x10,0xFC,0x9A,0x73,0x78,
+ 0xEA,0x28,0xC1,0x11,0x3B,0x07,0x46,0xEB,0xDE,0xF1,0xF3,0x2E,
+ 0xC7,0xC1,0x24,0xFB,0xC2,0x6C,0x4A,0x38,0x6C,0x9A,0x7F,0x87,
+ 0x76,0x30,0xF4,0xCC,0x21,0x49,0xC1,0x66,0x3D,0x95,0xE4,0xAA,
+ 0xE2,0x75,0x08,0xAB,0xEF,0xA2,0x51,0x30,0xFE,0x86,0xD0,0xE1,
+ 0x4C,0x05,0x0C,0xDE,0x63,0x93,0xB3,0x37,0x11,0x81,0xB5,0x8F,
+ 0x84,0xE2,0x48,0xC1,0xF6,0xF6,0xD6,0x50,0x91,0xDE,0x61,0x14,
+ 0x7B,0x6E,0x88,0x95,0x30,0x52,0xEF,0xA5,0x03,0x99,0xBE,0x50,
+ 0x97,0xE3,0x25,0x8F,0x50,0x01,0x9C,0x54,0x99,0x2E,0x4C,0x6A,
+ 0x61,0xD7,0x0D,0xB9,0xFE,0xE9,0xFC,0x37,0xC1,0x6A,0xDF,0x84,
+ 0xF4,0x5A,0x7E,0xBA,0x95,0x23,0x5C,0x41,0x35,0xDB,0xF9,0x1E,
+ 0x93,0xC6,0x29,0x8E,0x57,0x28,0x3D,0x3A,0xDE,0x31,0x86,0x69,
+ 0x3D,0xC3,0x8F,0x27,0x62,0x84,0x77,0x58,0x02,0x7F,0x90,0x76,
+ 0x2D,0xDF,0x45,0x70,0x3F,0x04,0x44,0x5C,0xD1,0x8C,0x73,0x5E,
+ 0xB5,0xC8,0x9A,0x72,0x3E,0xA9,0x4D,0xFC,0xDC,0xAC,0x7B,0xFF,
+ 0x54,0xC2,0x7B,0x3B,0x11,0x6B,0x14,0xA3,0x50,0xDB,0x14,0xB0,
+ 0x89,0x5A,0xE7,0xDD,0xBF,0x1E,0x27,0xBC,0xC6,0x30,0xC4,0xD6,
+ 0x74,0x13,0x26,0xBA,0x67,0x15,0x56,0x42,0xED,0xDA,0xFF,0x9F,
+ 0x4B,0xBE,0x3E,0xBC,0xD0,0xA8,0xCA,0xB1,0x8E,0xB7,0xD0,0xFF,
+ 0xE0,0x87,0x67,0xE4,0x51,0xA4,0xB9,0xF3,0x47,0xFA,0x13,0xFA,
+ 0xB1,0xDA,0xB6,0xF8,0xEC,0x6D,0x0B,0x2E,0x99,0x37,0xB8,0x66,
+ 0x80,0x83,0x3A,0xCA,0x46,0x6D,0xDC,0x24,0x9F,0x83,0x54,0xA9,
+ 0x70,0x62,0x21,0x6D,0x28,0x0E,0x63,0x8B,0x91,0x7F,0xFF,0xCD,
+ 0x80,0xF5,0xAC,0xE6,0x90,0x97,0x3C,0xB5,0xE8,0x00,0x90,0x96,
+ 0xB7,0x26,0x2C,0xB2,0x9C,0xEF,0xBF,0xCC,0xD6,0xA8,0x01,0xA0,
+ 0xFC,0x20,0x61,0xBD,0xA9,0xEE,0x5F,0x8B,0x32,0x1C,0x62,0xF0,
+ 0x94,0x81,0x86,0x30,0x1B,0xB1,0x12,0xF5,0x58,0x52,0x8D,0xE4,
+ 0x99,0x43,0x60,0x9B,0x24,0xF8,0x8B,0x14,0x63,0x0C,0x93,0xF4,
+ 0x7A,0x70,0x0A,0xE1,0x45,0x16,0x92,0x9D,0x12,0x50,0x05,0x3C,
+ 0x05,0xEE,0x40,0x32,0x4D,0x99,0xFF,0xF6,0x14,0x25,0xF6,0xDF,
+ 0xD8,0xDA,0xE0,0x85,0x1B,0x3F,0x2C,0x50,0xD9,0x01,0x4B,0x01,
+ 0x65,0x2C,0x75,0x32,0xBA,0x6F,0x00,0x56,0xD3,0x83,0xC8,0x44,
+ 0x9B,0x62,0x3F,0x88,0xA7,0x18,0xAC,0x69,0xBB,0xF3,0x14,0xD3,
+ 0xA4,0x09,0x6C,0x4A,0x14,0x0C,0x55,0x95,0x7A,0x33,0x21,0x99,
+ 0x0F,0x01,0x00,0x5D,0x2D,0xAB,0xEB,0x7A,0x76,0x03,0xE7,0x2A,
+ 0x1D,0xC2,0x86,0x4B
+_EOF_
+ ;;
+ *)
+ return 1
+ ;;
+ esac
+
+ cat << \_EOF_
+ };
+ static unsigned char dhg[] = {
+ 0x02,
+ };
+
+ DH *dh = DH_new();;
+ BIGNUM *dhp_bn, *dhg_bn;
+
+ if (dh == NULL) {
+ return NULL;
+ }
+
+ dhp_bn = BN_bin2bn(dhp, sizeof (dhp), NULL);
+ dhg_bn = BN_bin2bn(dhg, sizeof (dhg), NULL);
+
+#ifdef TCLTLS_OPENSSL_PRE_1_1_API
+ dh->p = dhp_bn;
+ dh->g = dhg_bn;
+
+ if (dhp_bn == NULL || dhg_bn == NULL) {
+#else
+ if (dhp_bn == NULL || dhg_bn == NULL || !DH_set0_pqg(dh, dhp_bn, NULL, dhg_bn)) {
+#endif
+ DH_free(dh);
+ BN_free(dhp_bn);
+ BN_free(dhg_bn);
+ return(NULL);
+ }
+
+ return(dh);
+}
+_EOF_
+
+ return 0
+}
+
+# Enable support for giving the same DH params each time
+if [ "${option_fallback}" = '1' ]; then
+ gen_dh_params_fallback && exit 0
+
+ echo "Unable to generate fallback parameters for DH of ${bits} bits" >&2
+
+ exit 1
+fi
+
+echo "*****************************" >&2
+echo "** Generating DH Primes. **" >&2
+echo "** This will take a while. **" >&2
+echo "*****************************" >&2
+echo "Use OpenSSL" >&2
+gen_dh_params_openssl && exit 0
+echo "Use Remote" >&2
+gen_dh_params_remote && exit 0
+echo "Use fallback" >&2
+gen_dh_params_fallback && exit 0
+
+echo "Unable to generate parameters for DH of ${bits} bits" >&2
+
+exit 1
ADDED generic/tclOpts.h
Index: generic/tclOpts.h
==================================================================
--- /dev/null
+++ generic/tclOpts.h
@@ -0,0 +1,59 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman
+ *
+ * Stylized option processing - requires consistent
+ * 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 */
ADDED generic/tcltls.syms.in
Index: generic/tcltls.syms.in
==================================================================
--- /dev/null
+++ generic/tcltls.syms.in
@@ -0,0 +1,1 @@
+@SYMPREFIX@Tls_Init
ADDED generic/tcltls.vers
Index: generic/tcltls.vers
==================================================================
--- /dev/null
+++ generic/tcltls.vers
@@ -0,0 +1,6 @@
+{
+ global:
+ Tls_Init;
+ local:
+ *;
+};
ADDED generic/tls.c
Index: generic/tls.c
==================================================================
--- /dev/null
+++ generic/tls.c
@@ -0,0 +1,2030 @@
+/*
+ * 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
+#include
+#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 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))
+
+#define SSLKEYLOGFILE "SSLKEYLOGFILE"
+
+/*
+ * 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
+/* Added */
+#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;
+
+# if OPENSSL_VERSION_NUMBER < 0x10100000L
+
+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
+#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);
+ int code;
+
+ 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);
+ code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+ /* It got an error - reject the certificate. */
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ ok = 0;
+ } else {
+ result = Tcl_GetObjResult(statePtr->interp);
+ string = Tcl_GetStringFromObj(result, &length);
+ /* An empty result leaves verification unchanged. */
+ if (string != NULL && length > 0) {
+ code = Tcl_GetIntFromObj(statePtr->interp, result, &ok);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ 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;
+ int code;
+
+ 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);
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, TCL_ERROR);
+#endif
+ 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);
+ code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(statePtr->interp);
+#else
+ Tcl_BackgroundException(statePtr->interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+ Tcl_Release((ClientData) statePtr);
+ Tcl_Release((ClientData) statePtr->interp);
+}
+
+void KeyLogCallback(const SSL *ssl, const char *line) {
+ char *str = getenv(SSLKEYLOGFILE);
+ FILE *fd;
+ if (str) {
+ fd = fopen(str, "a");
+ fprintf(fd, "%s\n",line);
+ fclose(fd);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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 code;
+
+ 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) interp);
+ Tcl_Preserve((ClientData) statePtr);
+
+ Tcl_IncrRefCount(cmdPtr);
+ code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
+ Tcl_BackgroundError(interp);
+#else
+ Tcl_BackgroundException(interp, code);
+#endif
+ }
+ Tcl_DecrRefCount(cmdPtr);
+
+ Tcl_Release((ClientData) statePtr);
+
+ if (code == TCL_OK) {
+ char *ret = (char *) Tcl_GetStringResult(interp);
+ if (strlen(ret) < size - 1) {
+ strncpy(buf, ret, (size_t) size);
+ Tcl_Release((ClientData) interp);
+ return (int)strlen(ret);
+ }
+ }
+ Tcl_Release((ClientData) interp);
+ 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 clientData, 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 OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
+ return TCL_ERROR;
+#else
+ ctx = SSL_CTX_new(SSLv2_method()); break;
+#endif
+ case TLS_SSL3:
+#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
+ return TCL_ERROR;
+#else
+ ctx = SSL_CTX_new(SSLv3_method()); break;
+#endif
+ case TLS_TLS1:
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+ Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_1)
+ Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_2)
+ Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_3)
+ Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
+ return TCL_ERROR;
+#else
+ ctx = SSL_CTX_new(TLS_method());
+ SSL_CTX_set_min_proto_version(ctx, TLS1_3_VERSION);
+ SSL_CTX_set_max_proto_version(ctx, TLS1_3_VERSION);
+ break;
+#endif
+ default:
+ break;
+ }
+ if (ctx == NULL) {
+ Tcl_AppendResult(interp, REASON(), NULL);
+ return TCL_ERROR;
+ }
+ ssl = SSL_new(ctx);
+ if (ssl == NULL) {
+ Tcl_AppendResult(interp, REASON(), 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 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 */
+ 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 */
+ Tcl_Obj *alpn = NULL;
+#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 OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(OPENSSL_NO_SSL2) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL3) && !defined(NO_SSL2)
+ ssl2 = 1;
+#endif
+#if !defined(OPENSSL_NO_SSL3) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL2) && !defined(NO_SSL3)
+ ssl3 = 1;
+#endif
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+ tls1 = 0;
+#endif
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
+ tls1_1 = 0;
+#endif
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
+ tls1_2 = 0;
+#endif
+#if defined(NO_TLS1_3) || defined(OPENSSL_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);
+ OPTOBJ("-alpn", alpn);
+#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", "-alpn, -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;
+ }
+ }
+ if (alpn) {
+ /* Convert a Tcl list into a protocol-list in wire-format */
+ unsigned char *protos, *p;
+ unsigned int protoslen = 0;
+ int i, len, cnt;
+ Tcl_Obj **list;
+ if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ /* Determine the memory required for the protocol-list */
+ for (i = 0; i < cnt; i++) {
+ Tcl_GetStringFromObj(list[i], &len);
+ if (len > 255) {
+ Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ return TCL_ERROR;
+ }
+ protoslen += 1 + len;
+ }
+ /* Build the complete protocol-list */
+ protos = ckalloc(protoslen);
+ /* protocol-lists consist of 8-bit length-prefixed, byte strings */
+ for (i = 0, p = protos; i < cnt; i++) {
+ char *str = Tcl_GetStringFromObj(list[i], &len);
+ *p++ = len;
+ memcpy(p, str, len);
+ p += len;
+ }
+ /* Note: This functions reverses the return value convention */
+ if (SSL_set_alpn_protos(statePtr->ssl, protos, protoslen)) {
+ Tcl_AppendResult(interp, "failed to set alpn protocols", (char *) NULL);
+ Tls_Free((char *) statePtr);
+ ckfree(protos);
+ return TCL_ERROR;
+ }
+ /* SSL_set_alpn_protos makes a copy of the protocol-list */
+ ckfree(protos);
+ }
+#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 clientData, 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(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 OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
+ if (ENABLED(proto, TLS_PROTO_SSL2)) {
+ Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
+ if (ENABLED(proto, TLS_PROTO_SSL3)) {
+ Tcl_AppendResult(interp, "SSL3 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
+ if (ENABLED(proto, TLS_PROTO_TLS1)) {
+ Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
+ if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
+ Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
+ if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
+ Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
+ if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
+ Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", NULL);
+ return (SSL_CTX *)0;
+ }
+#endif
+
+ switch (proto) {
+#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ case TLS_PROTO_SSL2:
+ method = SSLv2_method();
+ break;
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ case TLS_PROTO_SSL3:
+ method = SSLv3_method();
+ break;
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ case TLS_PROTO_TLS1:
+ method = TLSv1_method();
+ break;
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ case TLS_PROTO_TLS1_1:
+ method = TLSv1_1_method();
+ break;
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ case TLS_PROTO_TLS1_2:
+ method = TLSv1_2_method();
+ break;
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_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:
+#if OPENSSL_VERSION_NUMBER >= 0x10100000L
+ /* Negotiate highest available SSL/TLS version */
+ method = TLS_method();
+#else
+ method = SSLv23_method();
+#endif
+#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
+ off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2);
+#endif
+#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
+ off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
+#endif
+#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1);
+#endif
+#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1);
+#endif
+#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
+ off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2);
+#endif
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_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 (getenv(SSLKEYLOGFILE)) {
+ SSL_CTX_set_keylog_callback(ctx, KeyLogCallback);
+ }
+
+#if !defined(NO_TLS1_3) && !defined(OPENSSL_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);
+
+ if (!isServer) {
+ SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE);
+ }
+ }
+#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); /* disable protocol versions */
+#if OPENSSL_VERSION_NUMBER < 0x10101000L
+ SSL_CTX_set_mode(ctx, SSL_MODE_AUTO_RETRY); /* handle new handshakes in background */
+#endif
+ 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 clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ State *statePtr;
+ X509 *peer;
+ Tcl_Obj *objPtr;
+ Tcl_Channel chan;
+ char *channelName, *ciphers;
+ int mode;
+#ifndef OPENSSL_NO_TLSEXT
+ const unsigned char *proto;
+ unsigned int len;
+#endif
+
+ 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-through ... */
+#if defined(__GNUC__)
+ __attribute__((fallthrough));
+#endif
+ 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));
+ }
+
+#ifndef OPENSSL_NO_TLSEXT
+ /* Report the selected protocol as a result of the negotiation */
+ SSL_get0_alpn_selected(statePtr->ssl, &proto, &len);
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
+ Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len));
+#endif
+ 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 clientData, 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 clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
+ static const char *commands [] = { "req", "strreq", NULL };
+ enum command { C_REQ, C_STRREQ, C_DUMMY };
+ int cmd, isStr;
+ char buffer[16384];
+
+ 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;
+ }
+
+ isStr = (cmd == C_STRREQ);
+ switch ((enum command) cmd) {
+ case C_REQ:
+ case C_STRREQ: {
+ 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 OPENSSL_VERSION_NUMBER <= 0x10100000L
+ RSA *rsa = NULL;
+#elif OPENSSL_VERSION_NUMBER < 0x30000000L
+ BIGNUM *bne = NULL;
+ RSA *rsa = NULL;
+#else
+ EVP_PKEY_CTX *ctx = NULL;
+#endif
+
+ 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 (isStr) {
+ Tcl_SetVar(interp,keyout,"",0);
+ Tcl_SetVar(interp,pemout,"",0);
+ }
+
+ 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 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
+ return(TCL_ERROR);
+ }
+
+ X509_set_version(cert,2);
+ ASN1_INTEGER_set(X509_get_serialNumber(cert),serial);
+#if OPENSSL_VERSION_NUMBER < 0x10100000L
+ X509_gmtime_adj(X509_get_notBefore(cert),0);
+ X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days);
+#else
+ X509_gmtime_adj(X509_getm_notBefore(cert),0);
+ X509_gmtime_adj(X509_getm_notAfter(cert),(long)60*60*24*days);
+#endif
+ X509_set_pubkey(cert,pkey);
+
+ name=X509_get_subject_name(cert);
+
+ X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, (const unsigned char *) k_C, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (const unsigned char *) k_ST, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (const unsigned char *) k_L, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (const unsigned char *) k_O, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (const unsigned char *) k_OU, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (const unsigned char *) k_CN, -1, -1, 0);
+ X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (const unsigned char *) k_Email, -1, -1, 0);
+
+ X509_set_subject_name(cert,name);
+
+ if (!X509_sign(cert,pkey,EVP_sha256())) {
+ X509_free(cert);
+ EVP_PKEY_free(pkey);
+#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
+ Tcl_SetResult(interp,"Error signing certificate",NULL);
+ return TCL_ERROR;
+ }
+
+ if (isStr) {
+ out=BIO_new(BIO_s_mem());
+ PEM_write_bio_X509(out,cert);
+ i=BIO_read(out,buffer,sizeof(buffer)-1);
+ i=(i<0) ? 0 : i;
+ buffer[i]='\0';
+ Tcl_SetVar(interp,pemout,buffer,0);
+ BIO_flush(out);
+ BIO_free(out);
+ } else {
+ out=BIO_new(BIO_s_file());
+ BIO_write_filename(out,pemout);
+ PEM_write_bio_X509(out,cert);
+ BIO_free_all(out);
+ }
+
+ X509_free(cert);
+ EVP_PKEY_free(pkey);
+#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
+ BN_free(bne);
+#endif
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ return TCL_OK;
+ clientData = clientData;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Free --
+ *
+ * This procedure cleans up when a SSL socket based channel
+ * is closed and its reference count falls below 1
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Frees all the state
+ *
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Free(char *blockPtr) {
+ 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, initialize 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.
+ * ------------------------------------------------*
+ *
+ * Side effects:
+ * 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:
+ * initializes 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);
+
+#if OPENSSL_VERSION_NUMBER < 0x10000000L
+ CRYPTO_set_locking_callback(NULL);
+ CRYPTO_set_id_callback(NULL);
+#elif OPENSSL_VERSION_NUMBER < 0x10100000L
+ CRYPTO_set_locking_callback(NULL);
+ CRYPTO_THREADID_set_callback(NULL)
+#endif
+
+ 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)
+#if OPENSSL_VERSION_NUMBER < 0x10100000L
+ num_locks = CRYPTO_num_locks();
+#else
+ num_locks = 1;
+#endif
+ locksCount = (int) num_locks;
+ locks = malloc(sizeof(*locks) * num_locks);
+ memset(locks, 0, sizeof(*locks) * num_locks);
+
+#if OPENSSL_VERSION_NUMBER < 0x10000000L
+ CRYPTO_set_locking_callback(CryptoThreadLockCallback);
+ CRYPTO_set_id_callback(CryptoThreadIdCallback);
+#elif OPENSSL_VERSION_NUMBER < 0x10100000L
+ CRYPTO_set_locking_callback(CryptoThreadLockCallback);
+ CRYPTO_THREADID_set_callback(CryptoThreadIdCallback)
+#endif
+#endif
+
+# if OPENSSL_VERSION_NUMBER < 0x10100000L
+ if (SSL_library_init() != 1) {
+ status = TCL_ERROR;
+ goto done;
+ }
+#else
+ /* Initialize BOTH libcrypto and libssl. */
+ OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS | OPENSSL_INIT_LOAD_CRYPTO_STRINGS
+ | OPENSSL_INIT_ADD_ALL_CIPHERS | OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);
+#endif
+
+# if OPENSSL_VERSION_NUMBER < 0x10100000L
+ SSL_load_error_strings();
+ ERR_load_crypto_strings();
+#else
+ OPENSSL_init_crypto(OPENSSL_INIT_LOAD_CRYPTO_STRINGS, NULL);
+#endif
+
+ 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
+
+# if OPENSSL_VERSION_NUMBER < 0x10100000L
+done:
+#endif
+#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,30 @@
+/*
+ * 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,341 @@
+/*
+ * 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
+
+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)", (void *) 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 = ((chan) ? Tcl_Eof(chan) : 1);
+ break;
+ case BIO_CTRL_PENDING:
+ dprintf("Got BIO_CTRL_PENDING");
+ ret = ((chan) ? ((Tcl_InputBuffered(chan) ? 1 : 0)) : 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 = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
+ dprintf("BIO_CTRL_FLUSH returning value %li", ret);
+ break;
+ case BIO_CTRL_PUSH:
+ dprintf("Got BIO_CTRL_PUSH");
+ ret = 0;
+ break;
+ case BIO_CTRL_POP:
+ dprintf("Got BIO_CTRL_POP");
+ ret = 0;
+ break;
+ case BIO_CTRL_SET:
+ dprintf("Got BIO_CTRL_SET");
+ ret = 0;
+ break;
+ case BIO_CTRL_GET :
+ dprintf("Got BIO_CTRL_GET ");
+ ret = 0;
+ break;
+#ifdef BIO_CTRL_GET_KTLS_SEND
+ case BIO_CTRL_GET_KTLS_SEND:
+ dprintf("Got BIO_CTRL_GET_KTLS_SEND");
+ ret = 0;
+ break;
+#endif
+#ifdef BIO_CTRL_GET_KTLS_RECV
+ case BIO_CTRL_GET_KTLS_RECV:
+ dprintf("Got BIO_CTRL_GET_KTLS_RECV");
+ ret = 0;
+ break;
+#endif
+ default:
+ dprintf("Got unknown control command (%i)", cmd);
+ ret = 0;
+ 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);
+}
+
+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);
+}
ADDED generic/tlsIO.c
Index: generic/tlsIO.c
==================================================================
--- /dev/null
+++ generic/tlsIO.c
@@ -0,0 +1,990 @@
+/*
+ * 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 void TlsChannelHandlerTimer(ClientData clientData);
+
+/*
+ * TLS Channel Type
+ */
+static Tcl_ChannelType *tlsChannelType = NULL;
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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);
+ return(0);
+
+ /* Interp is unused. */
+ interp = interp;
+}
+
+static int TlsCloseProc2(ClientData instanceData, Tcl_Interp *interp, int flags) {
+ if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
+ 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)", (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ if (*errorCodePtr == ECONNRESET) {
+ *errorCodePtr = ECONNABORTED;
+ }
+ } else {
+ dprintf("I/O error occurred (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ bytesRead = -1;
+ } else {
+ dprintf("I/O error occurred (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ } else {
+ dprintf("I/O error occurred (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);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsSetOptionProc --
+ *
+ * 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
+TlsSetOptionProc(ClientData instanceData, /* Socket state. */
+ Tcl_Interp *interp, /* For errors - can be NULL. */
+ const char *optionName, /* Name of the option to set the value for, or
+ * NULL to get all options and their values. */
+ const char *optionValue) /* Value for option. */
+{
+ State *statePtr = (State *) instanceData;
+
+ Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
+ Tcl_DriverSetOptionProc *setOptionProc;
+
+ setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
+ if (setOptionProc != NULL) {
+ return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
+ } 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;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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. */
+ 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(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) &&
+ ((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 occurred 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 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));
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * 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) {
+ /*
+ * Allocate new channeltype structure
+ */
+ size = sizeof(Tcl_ChannelType); /* Base size */
+
+ tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
+ memset((void *) tlsChannelType, 0, size);
+
+ tlsChannelType->typeName = "tls";
+#ifdef TCL_CHANNEL_VERSION_5
+ tlsChannelType->version = TCL_CHANNEL_VERSION_5;
+ tlsChannelType->closeProc = TlsCloseProc;
+ tlsChannelType->inputProc = TlsInputProc;
+ tlsChannelType->outputProc = TlsOutputProc;
+ tlsChannelType->seekProc = NULL;
+ tlsChannelType->setOptionProc = TlsSetOptionProc;
+ tlsChannelType->getOptionProc = TlsGetOptionProc;
+ tlsChannelType->watchProc = TlsWatchProc;
+ tlsChannelType->getHandleProc = TlsGetHandleProc;
+ tlsChannelType->close2Proc = TlsCloseProc2;
+ tlsChannelType->blockModeProc = TlsBlockModeProc;
+ tlsChannelType->flushProc = NULL;
+ tlsChannelType->handlerProc = TlsNotifyProc;
+ tlsChannelType->wideSeekProc = NULL;
+ tlsChannelType->threadActionProc = NULL;
+ tlsChannelType->truncateProc = NULL;
+#else
+ tlsChannelType->version = TCL_CHANNEL_VERSION_2;
+ tlsChannelType->closeProc = TlsCloseProc;
+ tlsChannelType->inputProc = TlsInputProc;
+ tlsChannelType->outputProc = TlsOutputProc;
+ tlsChannelType->seekProc = NULL;
+ tlsChannelType->setOptionProc = TlsSetOptionProc;
+ tlsChannelType->getOptionProc = TlsGetOptionProc;
+ tlsChannelType->watchProc = TlsWatchProc;
+ tlsChannelType->getHandleProc = TlsGetHandleProc;
+ tlsChannelType->close2Proc = NULL;
+ tlsChannelType->blockModeProc = TlsBlockModeProc;
+ tlsChannelType->flushProc = NULL;
+ tlsChannelType->handlerProc = TlsNotifyProc;
+#endif
+ }
+ return(tlsChannelType);
+}
ADDED generic/tlsInt.h
Index: generic/tlsInt.h
==================================================================
--- /dev/null
+++ generic/tlsInt.h
@@ -0,0 +1,178 @@
+/*
+ * 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 TCL 8.6 CONST changes */
+#ifndef CONST86
+#define CONST86
+#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 */
ADDED generic/tlsX509.c
Index: generic/tlsX509.c
==================================================================
--- /dev/null
+++ generic/tlsX509.c
@@ -0,0 +1,213 @@
+/*
+ * Copyright (C) 1997-2000 Sensus Consulting Ltd.
+ * Matt Newman
+ */
+#include
+#include
+#include
+#include
+#include
+#include
+#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(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
+ char sha1_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1];
+ unsigned char sha1_hash_binary[SHA_DIGEST_LENGTH];
+ char sha256_hash_ascii[SHA256_DIGEST_LENGTH * 2 + 1];
+ unsigned char sha256_hash_binary[SHA256_DIGEST_LENGTH];
+ const char *shachars="0123456789ABCDEF";
+
+ sha1_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0';
+ sha256_hash_ascii[SHA256_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);
+ }
+
+#if OPENSSL_VERSION_NUMBER < 0x10100000L
+ strcpy(notBefore, ASN1_UTCTIME_tostr(X509_get_notBefore(cert)));
+ strcpy(notAfter, ASN1_UTCTIME_tostr(X509_get_notAfter(cert)));
+#else
+ strcpy(notBefore, ASN1_UTCTIME_tostr(X509_getm_notBefore(cert)));
+ strcpy(notAfter, ASN1_UTCTIME_tostr(X509_getm_notAfter(cert)));
+#endif
+
+#ifndef NO_SSL_SHA
+ /* SHA1 */
+ X509_digest(cert, EVP_sha1(), sha1_hash_binary, NULL);
+ for (int n = 0; n < SHA_DIGEST_LENGTH; n++) {
+ sha1_hash_ascii[n*2] = shachars[(sha1_hash_binary[n] & 0xF0) >> 4];
+ sha1_hash_ascii[n*2+1] = shachars[(sha1_hash_binary[n] & 0x0F)];
+ }
+ Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) );
+ Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha1_hash_ascii, SHA_DIGEST_LENGTH * 2) );
+
+ /* SHA256 */
+ X509_digest(cert, EVP_sha256(), sha256_hash_binary, NULL);
+ for (int n = 0; n < SHA256_DIGEST_LENGTH; n++) {
+ sha256_hash_ascii[n*2] = shachars[(sha256_hash_binary[n] & 0xF0) >> 4];
+ sha256_hash_ascii[n*2+1] = shachars[(sha256_hash_binary[n] & 0x0F)];
+ }
+ Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "sha256_hash", -1) );
+ Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( sha256_hash_ascii, SHA256_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;
+}
ADDED library/tls.tcl
Index: library/tls.tcl
==================================================================
--- /dev/null
+++ library/tls.tcl
@@ -0,0 +1,399 @@
+#
+# 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
+ variable srvuid 0
+
+ # Over-ride this if you are using a different socket command
+ variable socketCmd
+ if {![info exists socketCmd]} {
+ set socketCmd [info command ::socket]
+ }
+
+ # This is the possible arguments to tls::socket and tls::init
+ # The format of this is a list of lists
+ ## Each inner list contains the following elements
+ ### Server (matched against "string match" for 0/1)
+ ### Option name
+ ### Variable to add the option to:
+ #### sopts: [socket] option
+ #### iopts: [tls::import] option
+ ### How many arguments the following the option to consume
+ variable socketOptionRules {
+ {0 -async sopts 0}
+ {* -myaddr sopts 1}
+ {0 -myport sopts 1}
+ {* -type sopts 1}
+ {* -cadir iopts 1}
+ {* -cafile iopts 1}
+ {* -cert iopts 1}
+ {* -certfile iopts 1}
+ {* -cipher iopts 1}
+ {* -command iopts 1}
+ {* -dhparams iopts 1}
+ {* -key iopts 1}
+ {* -keyfile iopts 1}
+ {* -password iopts 1}
+ {* -request iopts 1}
+ {* -require iopts 1}
+ {* -autoservername discardOpts 1}
+ {* -servername iopts 1}
+ {* -alpn iopts 1}
+ {* -ssl2 iopts 1}
+ {* -ssl3 iopts 1}
+ {* -tls1 iopts 1}
+ {* -tls1.1 iopts 1}
+ {* -tls1.2 iopts 1}
+ {* -tls1.3 iopts 1}
+ }
+
+ # tls::socket and tls::init options as a humane readable string
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+
+ # Internal [switch] body to validate options
+ variable socketOptionsSwitchBody
+}
+
+proc tls::_initsocketoptions {} {
+ variable socketOptionRules
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ # Do not re-run if we have already been initialized
+ if {[info exists socketOptionsSwitchBody]} {
+ return
+ }
+
+ # Create several structures from our list of options
+ ## 1. options: a text representation of the valid options for the current
+ ## server type
+ ## 2. argSwitchBody: Switch body for processing arguments
+ set options(0) [list]
+ set options(1) [list]
+ set argSwitchBody [list]
+ foreach optionRule $socketOptionRules {
+ set ruleServer [lindex $optionRule 0]
+ set ruleOption [lindex $optionRule 1]
+ set ruleVarToUpdate [lindex $optionRule 2]
+ set ruleVarArgsToConsume [lindex $optionRule 3]
+
+ foreach server [list 0 1] {
+ if {![string match $ruleServer $server]} {
+ continue
+ }
+
+ lappend options($server) $ruleOption
+ }
+
+ switch -- $ruleVarArgsToConsume {
+ 0 {
+ set argToExecute {
+ lappend @VAR@ $arg
+ set argsArray($arg) true
+ }
+ }
+ 1 {
+ set argToExecute {
+ incr idx
+ if {$idx >= [llength $args]} {
+ return -code error "\"$arg\" option must be followed by value"
+ }
+ set argValue [lindex $args $idx]
+ lappend @VAR@ $arg $argValue
+ set argsArray($arg) $argValue
+ }
+ }
+ default {
+ return -code error "Internal argument construction error"
+ }
+ }
+
+ lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
+ }
+
+ # Add in the final options
+ lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
+ lappend argSwitchBody default break
+
+ # Set the final variables
+ set socketOptionsNoServer [join $options(0) {, }]
+ set socketOptionsServer [join $options(1) {, }]
+ set socketOptionsSwitchBody $argSwitchBody
+}
+
+proc tls::initlib {dir dll} {
+ # Package index cd's into the package directory for loading.
+ # Irrelevant to unixoids, but for Windows this enables the OS to find
+ # the dependent DLL's in the CWD, where they may be.
+ set cwd [pwd]
+ catch {cd $dir}
+ if {[string equal $::tcl_platform(platform) "windows"] &&
+ ![string equal [lindex [file system $dir] 0] "native"]} {
+ # If it is a wrapped executable running on windows, the openssl
+ # dlls must be copied out of the virtual filesystem to the disk
+ # where Windows will find them when resolving the dependency in
+ # the tls dll. We choose to make them siblings of the executable.
+ package require starkit
+ set dst [file nativename [file dirname $starkit::topdir]]
+ foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] {
+ catch {file delete -force $dst/$sdll}
+ catch {file copy -force $dir/$sdll $dst/$sdll}
+ }
+ }
+ set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
+ catch {cd $cwd}
+ if {$res} {
+ namespace eval [namespace parent] {namespace delete tls}
+ return -code $res $err
+ }
+ rename tls::initlib {}
+}
+
+
+#
+# Backwards compatibility, also used to set the default
+# context options
+#
+proc tls::init {args} {
+ variable defaults
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ tls::_initsocketoptions
+
+ # Technically a third option should be used here: Options that are valid
+ # only a both servers and non-servers
+ set server -1
+ set options $socketOptionsServer
+
+ # Validate arguments passed
+ set initialArgs $args
+ set argc [llength $args]
+
+ array set argsArray [list]
+ for {set idx 0} {$idx < $argc} {incr idx} {
+ set arg [lindex $args $idx]
+ switch -glob -- $server,$arg $socketOptionsSwitchBody
+ }
+
+ set defaults $initialArgs
+}
+#
+# Helper function - behaves exactly as the native socket command.
+#
+proc tls::socket {args} {
+ variable socketCmd
+ variable defaults
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ tls::_initsocketoptions
+
+ set idx [lsearch $args -server]
+ if {$idx != -1} {
+ set server 1
+ set callback [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+
+ set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
+ set options $socketOptionsServer
+ } else {
+ set server 0
+
+ set usage "wrong # args: should be \"tls::socket ?options? host port\""
+ set options $socketOptionsNoServer
+ }
+
+ # Combine defaults with current options
+ set args [concat $defaults $args]
+
+ set argc [llength $args]
+ set sopts {}
+ set iopts [list -server $server]
+
+ array set argsArray [list]
+ for {set idx 0} {$idx < $argc} {incr idx} {
+ set arg [lindex $args $idx]
+ switch -glob -- $server,$arg $socketOptionsSwitchBody
+ }
+
+ if {$server} {
+ if {($idx + 1) != $argc} {
+ return -code error $usage
+ }
+ set uid [incr ::tls::srvuid]
+
+ set port [lindex $args [expr {$argc-1}]]
+ lappend sopts $port
+ #set sopts [linsert $sopts 0 -server $callback]
+ set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
+ #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
+ } else {
+ if {($idx + 2) != $argc} {
+ return -code error $usage
+ }
+
+ set host [lindex $args [expr {$argc-2}]]
+ set port [lindex $args [expr {$argc-1}]]
+
+ # If an "-autoservername" option is found, honor it
+ if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
+ if {![info exists argsArray(-servername)]} {
+ set argsArray(-servername) $host
+ lappend iopts -servername $host
+ }
+ }
+
+ lappend sopts $host $port
+ }
+ #
+ # Create TCP/IP socket
+ #
+ set chan [eval $socketCmd $sopts]
+ if {!$server && [catch {
+ #
+ # Push SSL layer onto socket
+ #
+ eval [list tls::import] $chan $iopts
+ } err]} {
+ set info ${::errorInfo}
+ catch {close $chan}
+ return -code error -errorinfo $info $err
+ }
+ return $chan
+}
+
+# tls::_accept --
+#
+# This is the actual accept that TLS sockets use, which then calls
+# the callback registered by tls::socket.
+#
+# Arguments:
+# iopts tls::import opts
+# callback server callback to invoke
+# chan socket channel to accept/deny
+# ipaddr calling IP address
+# port calling port
+#
+# Results:
+# Returns an error if the callback throws one.
+#
+proc tls::_accept { iopts callback chan ipaddr port } {
+ log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
+
+ set chan [eval [list tls::import $chan] $iopts]
+
+ lappend callback $chan $ipaddr $port
+ if {[catch {
+ uplevel #0 $callback
+ } err]} {
+ log 1 "tls::_accept error: ${::errorInfo}"
+ close $chan
+ error $err $::errorInfo $::errorCode
+ } else {
+ log 2 "tls::_accept - called \"$callback\" succeeded"
+ }
+}
+#
+# Sample callback for hooking: -
+#
+# error
+# verify
+# info
+#
+proc tls::callback {option args} {
+ variable debug
+
+ #log 2 [concat $option $args]
+
+ switch -- $option {
+ "error" {
+ foreach {chan msg} $args break
+
+ log 0 "TLS/$chan: error: $msg"
+ }
+ "verify" {
+ # poor man's lassign
+ foreach {chan depth cert rc err} $args break
+
+ array set c $cert
+
+ if {$rc != "1"} {
+ log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
+ } else {
+ log 2 "TLS/$chan: verify/$depth: $c(subject)"
+ }
+ if {$debug > 0} {
+ return 1; # FORCE OK
+ } else {
+ return $rc
+ }
+ }
+ "info" {
+ # poor man's lassign
+ foreach {chan major minor state msg} $args break
+
+ if {$msg != ""} {
+ append state ": $msg"
+ }
+ # For tracing
+ upvar #0 tls::$chan cb
+ set cb($major) $minor
+
+ log 2 "TLS/$chan: $major/$minor: $state"
+ }
+ default {
+ return -code error "bad option \"$option\":\
+ must be one of error, info, or verify"
+ }
+ }
+}
+
+proc tls::xhandshake {chan} {
+ upvar #0 tls::$chan cb
+
+ if {[info exists cb(handshake)] && \
+ $cb(handshake) == "done"} {
+ return 1
+ }
+ while {1} {
+ vwait tls::${chan}(handshake)
+ if {![info exists cb(handshake)]} {
+ return 0
+ }
+ if {$cb(handshake) == "done"} {
+ return 1
+ }
+ }
+}
+
+proc tls::password {} {
+ log 0 "TLS/Password: did you forget to set your passwd!"
+ # Return the worlds best kept secret password.
+ return "secret"
+}
+
+proc tls::log {level msg} {
+ variable debug
+ variable logcmd
+
+ if {$level > $debug || $logcmd == ""} {
+ return
+ }
+ set cmd $logcmd
+ lappend cmd $msg
+ uplevel #0 $cmd
+}
+
DELETED tclOpts.h
Index: tclOpts.h
==================================================================
--- tclOpts.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Matt Newman
- *
- * Stylized option processing - requires consistent
- * 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 */
DELETED tcltls.syms.in
Index: tcltls.syms.in
==================================================================
--- tcltls.syms.in
+++ /dev/null
@@ -1,1 +0,0 @@
-@SYMPREFIX@Tls_Init
DELETED tcltls.vers
Index: tcltls.vers
==================================================================
--- tcltls.vers
+++ /dev/null
@@ -1,6 +0,0 @@
-{
- global:
- Tls_Init;
- local:
- *;
-};
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]]]
DELETED tls.c
Index: tls.c
==================================================================
--- tls.c
+++ /dev/null
@@ -1,2093 +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
-#include
-#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 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))
-
-#define SSLKEYLOGFILE "SSLKEYLOGFILE"
-
-/*
- * 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
-/* Added */
-#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;
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
-
-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
-#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);
- int code;
-
- 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);
- code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
- if (code != TCL_OK) {
- /* It got an error - reject the certificate. */
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- ok = 0;
- } else {
- result = Tcl_GetObjResult(statePtr->interp);
- string = Tcl_GetStringFromObj(result, &length);
- /* An empty result leaves verification unchanged. */
- if (string != NULL && length > 0) {
- code = Tcl_GetIntFromObj(statePtr->interp, result, &ok);
- if (code != TCL_OK) {
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- 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;
- int code;
-
- 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);
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, TCL_ERROR);
-#endif
- 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);
- code = Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
- if (code != TCL_OK) {
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(statePtr->interp);
-#else
- Tcl_BackgroundException(statePtr->interp, code);
-#endif
- }
- Tcl_DecrRefCount(cmdPtr);
-
- Tcl_Release((ClientData) statePtr);
- Tcl_Release((ClientData) statePtr->interp);
-}
-
-void KeyLogCallback(const SSL *ssl, const char *line) {
- char *str = getenv(SSLKEYLOGFILE);
- FILE *fd;
- if (str) {
- fd = fopen(str, "a");
- fprintf(fd, "%s\n",line);
- fclose(fd);
- }
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * 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 code;
-
- 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) interp);
- Tcl_Preserve((ClientData) statePtr);
-
- Tcl_IncrRefCount(cmdPtr);
- code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
- if (code != TCL_OK) {
-#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
- Tcl_BackgroundError(interp);
-#else
- Tcl_BackgroundException(interp, code);
-#endif
- }
- Tcl_DecrRefCount(cmdPtr);
-
- Tcl_Release((ClientData) statePtr);
-
- if (code == TCL_OK) {
- char *ret = (char *) Tcl_GetStringResult(interp);
- if (strlen(ret) < size - 1) {
- strncpy(buf, ret, (size_t) size);
- Tcl_Release((ClientData) interp);
- return (int)strlen(ret);
- }
- }
- Tcl_Release((ClientData) interp);
- return -1;
-}
-#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 clientData, 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 OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
- Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(SSLv2_method()); break;
-#endif
- case TLS_SSL3:
-#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
- Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(SSLv3_method()); break;
-#endif
- case TLS_TLS1:
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
- Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_1)
- Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_2)
- Tcl_AppendResult(interp, protocols[index], ": 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) || defined(OPENSSL_NO_TLS1_3)
- Tcl_AppendResult(interp, protocols[index], ": protocol not supported", NULL);
- return TCL_ERROR;
-#else
- ctx = SSL_CTX_new(TLS_method());
- SSL_CTX_set_min_proto_version (ctx, TLS1_3_VERSION);
- SSL_CTX_set_max_proto_version (ctx, TLS1_3_VERSION);
- break;
-#endif
- default:
- break;
- }
- if (ctx == NULL) {
- Tcl_AppendResult(interp, REASON(), NULL);
- return TCL_ERROR;
- }
- ssl = SSL_new(ctx);
- if (ssl == NULL) {
- Tcl_AppendResult(interp, REASON(), 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 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 */
- 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 */
- Tcl_Obj *alpn = NULL;
-#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 OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(OPENSSL_NO_SSL2) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL3) && !defined(NO_SSL2)
- ssl2 = 1;
-#endif
-#if !defined(OPENSSL_NO_SSL3) && defined(NO_TLS1) && defined(NO_TLS1_1) && defined(NO_TLS1_2) && defined(NO_TLS1_3) && defined(NO_SSL2) && !defined(NO_SSL3)
- ssl3 = 1;
-#endif
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
- tls1 = 0;
-#endif
-#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
- tls1_1 = 0;
-#endif
-#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
- tls1_2 = 0;
-#endif
-#if defined(NO_TLS1_3) || defined(OPENSSL_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);
- OPTOBJ( "-alpn", alpn);
-#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", "-alpn, -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;
- }
- }
- if (alpn) {
- /* Convert a Tcl list into a protocol-list in wire-format */
- unsigned char *protos, *p;
- unsigned int protoslen = 0;
- int i, len, cnt;
- Tcl_Obj **list;
- if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) {
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
- /* Determine the memory required for the protocol-list */
- for (i = 0; i < cnt; i++) {
- Tcl_GetStringFromObj(list[i], &len);
- if (len > 255) {
- Tcl_AppendResult(interp, "alpn protocol name too long",
- (char *) NULL);
- Tls_Free((char *) statePtr);
- return TCL_ERROR;
- }
- protoslen += 1 + len;
- }
- /* Build the complete protocol-list */
- protos = ckalloc(protoslen);
- /* protocol-lists consist of 8-bit length-prefixed, byte strings */
- for (i = 0, p = protos; i < cnt; i++) {
- char *str = Tcl_GetStringFromObj(list[i], &len);
- *p++ = len;
- memcpy(p, str, len);
- p += len;
- }
- /* Note: This functions reverses the return value convention */
- if (SSL_set_alpn_protos(statePtr->ssl, protos, protoslen)) {
- Tcl_AppendResult(interp, "failed to set alpn protocols",
- (char *) NULL);
- Tls_Free((char *) statePtr);
- ckfree(protos);
- return TCL_ERROR;
- }
- /* SSL_set_alpn_protos makes a copy of the protocol-list */
- ckfree(protos);
- }
-#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 clientData, 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(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 OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2)
- if (ENABLED(proto, TLS_PROTO_SSL2)) {
- Tcl_AppendResult(interp, "SSL2 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_SSL3) || defined(OPENSSL_NO_SSL3)
- if (ENABLED(proto, TLS_PROTO_SSL3)) {
- Tcl_AppendResult(interp, "SSL3 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1) || defined(OPENSSL_NO_TLS1)
- if (ENABLED(proto, TLS_PROTO_TLS1)) {
- Tcl_AppendResult(interp, "TLS 1.0 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_1) || defined(OPENSSL_NO_TLS1_1)
- if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
- Tcl_AppendResult(interp, "TLS 1.1 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_2) || defined(OPENSSL_NO_TLS1_2)
- if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
- Tcl_AppendResult(interp, "TLS 1.2 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-#if defined(NO_TLS1_3) || defined(OPENSSL_NO_TLS1_3)
- if (ENABLED(proto, TLS_PROTO_TLS1_3)) {
- Tcl_AppendResult(interp, "TLS 1.3 protocol not supported", NULL);
- return (SSL_CTX *)0;
- }
-#endif
-
- switch (proto) {
-#if OPENSSL_VERSION_NUMBER < 0x10101000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
- case TLS_PROTO_SSL2:
- method = SSLv2_method();
- break;
-#endif
-#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
- case TLS_PROTO_SSL3:
- method = SSLv3_method();
- break;
-#endif
-#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
- case TLS_PROTO_TLS1:
- method = TLSv1_method();
- break;
-#endif
-#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
- case TLS_PROTO_TLS1_1:
- method = TLSv1_1_method();
- break;
-#endif
-#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
- case TLS_PROTO_TLS1_2:
- method = TLSv1_2_method();
- break;
-#endif
-#if !defined(NO_TLS1_3) && !defined(OPENSSL_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:
-#if OPENSSL_VERSION_NUMBER >= 0x10100000L
- /* Negotiate highest available SSL/TLS version */
- method = TLS_method();
-#else
- method = SSLv23_method();
-#endif
-#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2)
- off |= (ENABLED(proto, TLS_PROTO_SSL2) ? 0 : SSL_OP_NO_SSLv2);
-#endif
-#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3)
- off |= (ENABLED(proto, TLS_PROTO_SSL3) ? 0 : SSL_OP_NO_SSLv3);
-#endif
-#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1)
- off |= (ENABLED(proto, TLS_PROTO_TLS1) ? 0 : SSL_OP_NO_TLSv1);
-#endif
-#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1)
- off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1);
-#endif
-#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2)
- off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2);
-#endif
-#if !defined(NO_TLS1_3) && !defined(OPENSSL_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 (getenv(SSLKEYLOGFILE)) {
- SSL_CTX_set_keylog_callback(ctx, KeyLogCallback);
- }
-
-#if !defined(NO_TLS1_3) && !defined(OPENSSL_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);
-
- if (!isServer) {
- SSL_CTX_set_options(ctx, SSL_OP_CIPHER_SERVER_PREFERENCE);
- }
- }
-#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 */
-#if OPENSSL_VERSION_NUMBER < 0x10101000L
- SSL_CTX_set_mode(ctx, SSL_MODE_AUTO_RETRY); /* handle new handshakes in background */
-#endif
- 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 clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- State *statePtr;
- X509 *peer;
- Tcl_Obj *objPtr;
- Tcl_Channel chan;
- char *channelName, *ciphers;
- int mode;
-#ifndef OPENSSL_NO_TLSEXT
- const unsigned char *proto;
- unsigned int len;
-#endif
-
- 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-through ... */
-#if defined(__GNUC__)
- __attribute__((fallthrough));
-#endif
- 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));
- }
-
-#ifndef OPENSSL_NO_TLSEXT
- /* Report the selected protocol as a result of the negotiation */
- SSL_get0_alpn_selected(statePtr->ssl, &proto, &len);
- Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1));
- Tcl_ListObjAppendElement(interp, objPtr,
- Tcl_NewStringObj((char *)proto, (int)len));
-#endif
- 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 clientData, 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 clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
- static const char *commands [] = { "req", "strreq", NULL };
- enum command { C_REQ, C_STRREQ, C_DUMMY };
- int cmd, isStr;
- char buffer[16384];
-
- 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;
- }
-
- isStr = (cmd == C_STRREQ);
- switch ((enum command) cmd) {
- case C_REQ:
- case C_STRREQ: {
- 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 OPENSSL_VERSION_NUMBER <= 0x10100000L
- RSA *rsa = NULL;
-#elif OPENSSL_VERSION_NUMBER < 0x30000000L
- BIGNUM *bne = NULL;
- RSA *rsa = NULL;
-#else
- EVP_PKEY_CTX *ctx = NULL;
-#endif
-
- 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 (isStr) {
- Tcl_SetVar(interp,keyout,"",0);
- Tcl_SetVar(interp,pemout,"",0);
- }
-
- 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 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
- BN_free(bne);
-#endif
- return(TCL_ERROR);
- }
-
- X509_set_version(cert,2);
- ASN1_INTEGER_set(X509_get_serialNumber(cert),serial);
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- X509_gmtime_adj(X509_get_notBefore(cert),0);
- X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days);
-#else
- X509_gmtime_adj(X509_getm_notBefore(cert),0);
- X509_gmtime_adj(X509_getm_notAfter(cert),(long)60*60*24*days);
-#endif
- X509_set_pubkey(cert,pkey);
-
- name=X509_get_subject_name(cert);
-
- X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, (const unsigned char *) k_C, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, (const unsigned char *) k_ST, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, (const unsigned char *) k_L, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, (const unsigned char *) k_O, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, (const unsigned char *) k_OU, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, (const unsigned char *) k_CN, -1, -1, 0);
- X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, (const unsigned char *) k_Email, -1, -1, 0);
-
- X509_set_subject_name(cert,name);
-
- if (!X509_sign(cert,pkey,EVP_sha256())) {
- X509_free(cert);
- EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
- BN_free(bne);
-#endif
- Tcl_SetResult(interp,"Error signing certificate",NULL);
- return TCL_ERROR;
- }
-
- if (isStr) {
- out=BIO_new(BIO_s_mem());
- PEM_write_bio_X509(out,cert);
- i=BIO_read(out,buffer,sizeof(buffer)-1);
- i=(i<0) ? 0 : i;
- buffer[i]='\0';
- Tcl_SetVar(interp,pemout,buffer,0);
- BIO_flush(out);
- BIO_free(out);
- } else {
- out=BIO_new(BIO_s_file());
- BIO_write_filename(out,pemout);
- PEM_write_bio_X509(out,cert);
- BIO_free_all(out);
- }
-
- X509_free(cert);
- EVP_PKEY_free(pkey);
-#if OPENSSL_VERSION_NUMBER > 0x10100000L && OPENSSL_VERSION_NUMBER < 0x30000000L
- BN_free(bne);
-#endif
- }
- }
- break;
- default:
- break;
- }
- return TCL_OK;
- clientData = clientData;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * Tls_Free --
- *
- * This procedure cleans up when a SSL socket based channel
- * is closed and its reference count falls below 1
- *
- * Results:
- * none
- *
- * Side effects:
- * Frees all the state
- *
- *-------------------------------------------------------------------
- */
-void
-Tls_Free( char *blockPtr )
-{
- 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, initialize 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.
- * ------------------------------------------------*
- *
- * Side effects:
- * 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:
- * initializes 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);
-
-#if OPENSSL_VERSION_NUMBER < 0x10000000L
- CRYPTO_set_locking_callback(NULL);
- CRYPTO_set_id_callback(NULL);
-#elif OPENSSL_VERSION_NUMBER < 0x10100000L
- CRYPTO_set_locking_callback(NULL);
- CRYPTO_THREADID_set_callback(NULL)
-#endif
-
- 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)
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- num_locks = CRYPTO_num_locks();
-#else
- num_locks = 1;
-#endif
- locksCount = (int) num_locks;
- locks = malloc(sizeof(*locks) * num_locks);
- memset(locks, 0, sizeof(*locks) * num_locks);
-
-#if OPENSSL_VERSION_NUMBER < 0x10000000L
- CRYPTO_set_locking_callback(CryptoThreadLockCallback);
- CRYPTO_set_id_callback(CryptoThreadIdCallback);
-#elif OPENSSL_VERSION_NUMBER < 0x10100000L
- CRYPTO_set_locking_callback(CryptoThreadLockCallback);
- CRYPTO_THREADID_set_callback(CryptoThreadIdCallback)
-#endif
-#endif
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
- if (SSL_library_init() != 1) {
- status = TCL_ERROR;
- goto done;
- }
-#else
- /* Initialize BOTH libcrypto and libssl. */
- OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS | OPENSSL_INIT_LOAD_CRYPTO_STRINGS
- | OPENSSL_INIT_ADD_ALL_CIPHERS | OPENSSL_INIT_ADD_ALL_DIGESTS, NULL);
-#endif
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
- SSL_load_error_strings();
- ERR_load_crypto_strings();
-#else
- /* Only initialize libcrypto */
- OPENSSL_init_crypto(OPENSSL_INIT_LOAD_CRYPTO_STRINGS, NULL);
-#endif
-
- 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
-
-# if OPENSSL_VERSION_NUMBER < 0x10100000L
-done:
-#endif
-#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 */
DELETED tls.htm
Index: tls.htm
==================================================================
--- tls.htm
+++ /dev/null
@@ -1,472 +0,0 @@
-
-
-
-
-
-
-
-TLS (SSL) Tcl Commands
-
-
-
-
-
- - NAME
- - tls - binding to OpenSSL
- toolkit.
-
-
- - SYNOPSIS
-
- - package require Tcl ?8.4?
- - package require tls ?@@VERS@@?
- -
- - tls::init ?options?
- - tls::socket ?options? host port
- - tls::socket ?-server command?
- ?options? port
- - tls::handshake channel
- - tls::status ?-local? channel
- - tls::import channel ?options?
- - tls::unimport channel
- - tls::ciphers protocol ?verbose?
- - tls::version
-
- - COMMANDS
- - CALLBACK OPTIONS
- - HTTPS EXAMPLE
- - SPECIAL CONSIDERATIONS
- - SEE ALSO
-
-
-
-
-
-
-tls - binding to OpenSSL
-toolkit.
-
-
-
-package require Tcl 8.4
-package require tls @@VERS@@
-
-tls::init ?options?
-tls::socket ?options? host
-port
-tls::socket ?-server command? ?options? port
-tls::status ?-local? channel
-tls::handshake channel
-
-tls::import channel ?options?
-tls::unimport channel
-tls::ciphers
-protocol ?verbose?
-tls::version
-
-
-
-
-This extension provides a generic binding to OpenSSL, utilizing the
-Tcl_StackChannel
-API for Tcl 8.4 and higher. The sockets behave exactly the same
-as channels created using Tcl's built-in socket
-command with additional options for controlling the SSL session.
-
-
-
-
-Typically one would use the tls::socket command
-which provides compatibility with the native Tcl socket
-command. In such cases tls::import should not be
-used directly.
-
-
- - tls::init ?options?
- - This routine sets the default options used by tls::socket
- and is optional. If you call tls::import
- directly this routine has no effect. Any of the options
- that tls::socket accepts can be set
- using this command, though you should limit your options
- to only TLS related ones.
- -
- - tls::socket ?options?
- host port
- - tls::socket ?-server command? ?options? port
- - This is a helper function that utilizes the underlying
- commands (tls::import). It behaves
- exactly the same as the native Tcl socket
- command except that the options can include any of the
- applicable tls:import
- options with one additional option:
-
-
- - -autoservername bool
- - Automatically send the -servername as the host argument
- (default: false)
-
-
- -
- - tls::handshake channel
- - Forces handshake to take place, and returns 0 if
- handshake is still in progress (non-blocking), or 1 if
- the handshake was successful. If the handshake failed
- this routine will throw an error.
- -
- - tls::status
- ?-local? channel
- - Returns the current security status of an SSL channel. The
- result is a list of key-value pairs describing the
- connected peer. If the result is an empty list then the
- SSL handshake has not yet completed.
- If -local is given, then the certificate information
- is the one used locally.
-
-
-
-
- - issuer dn
- - The distinguished name (DN) of the certificate
- issuer.
- - subject dn
- - The distinguished name (DN) of the certificate
- subject.
- - notBefore date
- - The begin date for the validity of the certificate.
- - notAfter date
- - The expiry date for the certificate.
- - serial n
- - The serial number of the certificate.
- - cipher cipher
- - The current cipher in use between the client and
- server channels.
- - sbits n
- - The number of bits used for the session key.
- - certificate cert
- - The PEM encoded certificate.
- - sha1_hash hash
- - The SHA1 hash of the certificate.
- - sha256_hash hash
- - The SHA256 hash of the certificate.
- - alpn protocol
- - The protocol selected after Application-Layer Protocol
- Negotiation (ALPN).
- - version value
- - The protocol version used for the connection:
- SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, unknown
-
-
-
-
- - tls::import channel
- ?options?
- - SSL-enable a regular Tcl channel - it need not be a
- socket, but must provide bi-directional flow. Also
- setting session parameters for SSL handshake.
-
-
-
-
- - -alpn list
- - List of protocols to offer during Application-Layer
- Protocol Negotiation (ALPN). For example: h2, http/1.1, etc.
- - -cadir dir
- - Provide the directory containing the CA certificates. The
- default directory is platform specific and can be set at
- compile time. This can be overridden via the SSL_CERT_DIR
- environment variable.
- - -cafile filename
- - Provide the CA file.
- - -certfile filename
- - Provide the name of a file containing certificate to use.
- The default name is cert.pem. This can be overridden via the
- SSL_CERT_FILE environment variable.
- - -cert filename
- - Provide the contents of a certificate to use, as a DER encoded binary value (X.509 DER).
- - -cipher string
- - Provide the cipher suites to use. Syntax is as per
- OpenSSL.
- - -command callback
- - If specified, this callback will be invoked at several points
- during the OpenSSL handshake. It can pass errors and tracing
- information, and it can allow Tcl scripts to perform
- their own validation of the certificate in place of the
- default validation provided by OpenSSL.
-
- See CALLBACK OPTIONS for
- further discussion.
- - -dhparams filename
- - Provide a Diffie-Hellman parameters file.
- - -keyfile filename
- - Provide the private key file. (default:
- value of -certfile)
- - -key filename
- - Provide the private key to use as a DER encoded value (PKCS#1 DER)
- - -model channel
- - This will force this channel to share the same SSL_CTX
- structure as the specified channel, and
- therefore share callbacks etc.
- - -password callback
- - If supplied, this callback will be invoked when OpenSSL needs
- to obtain a password, typically to unlock the private key of
- a certificate.
- The callback should return a string which represents the
- password to be used.
-
- See CALLBACK OPTIONS for
- further discussion.
- - -request bool
- - Request a certificate from peer during SSL handshake.
- (default: true)
- - -require bool
- - Require a valid certificate from peer during SSL
- handshake. If this is set to true then -request
- must also be set to true. (default: false)
- - -server bool
- - Handshake as server if true, else handshake as
- client.(default: false)
- - -servername host
- - Only available if the OpenSSL library the package is linked
- against supports the TLS hostname extension for 'Server Name
- Indication' (SNI). Use to name the logical host we are talking
- to and expecting a certificate for
- - -ssl2 bool
- - Enable use of SSL v2. (default: false)
- - -ssl3 bool
- - Enable use of SSL v3. (default: false)
- - -tls1 bool
- - Enable use of TLS v1. (default: true)
- - -tls1.1 bool
- - Enable use of TLS v1.1 (default: true)
- - -tls1.2 bool
- - Enable use of TLS v1.2 (default: true)
- - -tls1.3 bool
- - Enable use of TLS v1.3 (default: true)
-
-
-
-
- - tls::unimport channel
- - Provided for symmetry to tls::import, this
- unstacks the SSL-enabling of a regular Tcl channel. An error
- is thrown if TLS is not the top stacked channel type.
-
-
-
- - tls::ciphers
- protocol ?verbose?
- - Returns list of supported ciphers based on the protocol
- you supply, which must be one of ssl2, ssl3, or tls1.
- If verbose is specified as true then a verbose,
- semi-human readable list is returned providing additional
- information on the nature of the cipher support. In each
- case the result is a Tcl list.
-
-
-
- - tls::version
- - Returns the version string defined by OpenSSL.
-
-
-
-
-
-As indicated above, individual channels can be given their own callbacks
-to handle intermediate processing by the OpenSSL library, using the
--command and -password options passed to either of
-tls::socket or tls::import.
-
-
-
-
-
- - -command callback
- -
- Invokes the specified callback script at
- several points during the OpenSSL handshake.
- Except as indicated below, values returned from the
- callback are ignored.
- Arguments appended to the script upon callback take one of the
- following forms:
-
-
-
-
-
-
-
-
- -
- info channel major minor message
-
- -
- This form of callback is invoked by the OpenSSL function
-
SSL_CTX_set_info_callback().
-
- The major and minor arguments are used to
- represent the state information bitmask.
-
- - Possible values for major are:
- handshake, alert, connect, accept.- Possible values for minor are:
- start, done, read, write, loop, exit.
- The message argument is a descriptive string which may
- be generated either by
- SSL_state_string_long() or by
- SSL_alert_desc_string_long(),
- depending on context.
-
-
-
-
- -
- verify channel depth cert status error
-
- -
- This form of callback is invoked by the OpenSSL function
-
SSL_set_verify().
-
- The depth argument is an integer representing the
- current depth on the certificate chain, with
- 0 as the subject certificate and higher values
- denoting progressively more indirect issuer certificates.
-
- The cert argument is a list of key-value pairs similar
- to those returned by
- tls::status.
-
- The status argument is an integer representing the
- current validity of the certificate.
- A value of 0 means the certificate is deemed invalid.
- A value of 1 means the certificate is deemed valid.
-
- The error argument supplies the message, if any, generated
- by
- X509_STORE_CTX_get_error().
-
-
- The callback may override normal validation processing by explicitly
- returning one of the above status values.
-
-
-
-
-
-
-
- - -password callback
- -
- Invokes the specified callback script when OpenSSL needs to
- obtain a password. The callback should return a string which
- represents the password to be used.
- No arguments are appended to the script upon callback.
-
-
-
-
-
-Reference implementations of these callbacks are provided in the
-distribution as tls::callback and
-tls::password respectively. Note that these are
-sample implementations only. In a more realistic deployment
-you would specify your own callback scripts on each TLS channel
-using the -command and -password options.
-
-
-
-The default behavior when the -command option is not specified is for
-TLS to process the associated library callbacks internally.
-The default behavior when the -password option is not specified is for
-TLS to process the associated library callbacks by attempting to call
-tls::password.
-The difference between these two behaviors is a consequence of maintaining
-compatibility with earlier implementations.
-
-
-
-The tls::debug variable provides some additional
-control over these reference callbacks. Its value is zero by default.
-Higher values produce more diagnostic output, and will also force the
-verify method in tls::callback to accept the
-certificate, even when it is invalid.
-
-
-
-
-The use of the reference callbacks tls::callback and
-tls::password is not recommended. They may be removed
-from future releases.
-
-
-
-
-
-The use of the variable tls::debug is not recommended.
-It may be removed from future releases.
-
-
-
-
-
-TLS key logging can be enabled by setting the environment variable
-SSLKEYLOGFILE to the name of the file to log to. Then whenever TLS
-key material is generated or received it will be logged to the file.
-
-
-
-This example uses a sample server.pem provided with the TLS release,
-courtesy of the OpenSSL project.
-
-
-package require http
-package require tls
-
-http::register https 443 [list ::tls::socket -autoservername true -require true -cadir /etc/ssl/certs]
-
-set tok [http::geturl https://www.tcl.tk/]
-
-
-
-
-The capabilities of this package can vary enormously based
-upon how your OpenSSL library was configured and built. At the
-most macro-level OpenSSL supports a "no patents" build,
-which disables RSA, IDEA, RC(2,4,5) and SSL2 - if your OpenSSL is
-configured this way then you will need to build TLS with the
--DNO_PATENTS option - and the resultant module will function
-correctly and also support ADH certificate-less encryption,
-however you will be unable to utilize this to speak to normal Web
-Servers, which typically require RSA support. Please see http://www.openssl.org/ for
-more information on the whole issue of patents and US export
-restrictions.
-
-
-
-socket, fileevent, OpenSSL
-
-
-
-
-Copyright © 1999 Matt Newman.
-Copyright © 2004 Starfish Systems.
-
-
-
DELETED tls.tcl
Index: tls.tcl
==================================================================
--- tls.tcl
+++ /dev/null
@@ -1,399 +0,0 @@
-#
-# 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
- variable srvuid 0
-
- # Over-ride this if you are using a different socket command
- variable socketCmd
- if {![info exists socketCmd]} {
- set socketCmd [info command ::socket]
- }
-
- # This is the possible arguments to tls::socket and tls::init
- # The format of this is a list of lists
- ## Each inner list contains the following elements
- ### Server (matched against "string match" for 0/1)
- ### Option name
- ### Variable to add the option to:
- #### sopts: [socket] option
- #### iopts: [tls::import] option
- ### How many arguments the following the option to consume
- variable socketOptionRules {
- {0 -async sopts 0}
- {* -myaddr sopts 1}
- {0 -myport sopts 1}
- {* -type sopts 1}
- {* -cadir iopts 1}
- {* -cafile iopts 1}
- {* -cert iopts 1}
- {* -certfile iopts 1}
- {* -cipher iopts 1}
- {* -command iopts 1}
- {* -dhparams iopts 1}
- {* -key iopts 1}
- {* -keyfile iopts 1}
- {* -password iopts 1}
- {* -request iopts 1}
- {* -require iopts 1}
- {* -autoservername discardOpts 1}
- {* -servername iopts 1}
- {* -alpn iopts 1}
- {* -ssl2 iopts 1}
- {* -ssl3 iopts 1}
- {* -tls1 iopts 1}
- {* -tls1.1 iopts 1}
- {* -tls1.2 iopts 1}
- {* -tls1.3 iopts 1}
- }
-
- # tls::socket and tls::init options as a humane readable string
- variable socketOptionsNoServer
- variable socketOptionsServer
-
- # Internal [switch] body to validate options
- variable socketOptionsSwitchBody
-}
-
-proc tls::_initsocketoptions {} {
- variable socketOptionRules
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- # Do not re-run if we have already been initialized
- if {[info exists socketOptionsSwitchBody]} {
- return
- }
-
- # Create several structures from our list of options
- ## 1. options: a text representation of the valid options for the current
- ## server type
- ## 2. argSwitchBody: Switch body for processing arguments
- set options(0) [list]
- set options(1) [list]
- set argSwitchBody [list]
- foreach optionRule $socketOptionRules {
- set ruleServer [lindex $optionRule 0]
- set ruleOption [lindex $optionRule 1]
- set ruleVarToUpdate [lindex $optionRule 2]
- set ruleVarArgsToConsume [lindex $optionRule 3]
-
- foreach server [list 0 1] {
- if {![string match $ruleServer $server]} {
- continue
- }
-
- lappend options($server) $ruleOption
- }
-
- switch -- $ruleVarArgsToConsume {
- 0 {
- set argToExecute {
- lappend @VAR@ $arg
- set argsArray($arg) true
- }
- }
- 1 {
- set argToExecute {
- incr idx
- if {$idx >= [llength $args]} {
- return -code error "\"$arg\" option must be followed by value"
- }
- set argValue [lindex $args $idx]
- lappend @VAR@ $arg $argValue
- set argsArray($arg) $argValue
- }
- }
- default {
- return -code error "Internal argument construction error"
- }
- }
-
- lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
- }
-
- # Add in the final options
- lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
- lappend argSwitchBody default break
-
- # Set the final variables
- set socketOptionsNoServer [join $options(0) {, }]
- set socketOptionsServer [join $options(1) {, }]
- set socketOptionsSwitchBody $argSwitchBody
-}
-
-proc tls::initlib {dir dll} {
- # Package index cd's into the package directory for loading.
- # Irrelevant to unixoids, but for Windows this enables the OS to find
- # the dependent DLL's in the CWD, where they may be.
- set cwd [pwd]
- catch {cd $dir}
- if {[string equal $::tcl_platform(platform) "windows"] &&
- ![string equal [lindex [file system $dir] 0] "native"]} {
- # If it is a wrapped executable running on windows, the openssl
- # dlls must be copied out of the virtual filesystem to the disk
- # where Windows will find them when resolving the dependency in
- # the tls dll. We choose to make them siblings of the executable.
- package require starkit
- set dst [file nativename [file dirname $starkit::topdir]]
- foreach sdll [glob -nocomplain -directory $dir -tails libssl32.dll libcrypto*.dll libssl*.dll libssp*.dll] {
- catch {file delete -force $dst/$sdll}
- catch {file copy -force $dir/$sdll $dst/$sdll}
- }
- }
- set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
- catch {cd $cwd}
- if {$res} {
- namespace eval [namespace parent] {namespace delete tls}
- return -code $res $err
- }
- rename tls::initlib {}
-}
-
-
-#
-# Backwards compatibility, also used to set the default
-# context options
-#
-proc tls::init {args} {
- variable defaults
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- tls::_initsocketoptions
-
- # Technically a third option should be used here: Options that are valid
- # only a both servers and non-servers
- set server -1
- set options $socketOptionsServer
-
- # Validate arguments passed
- set initialArgs $args
- set argc [llength $args]
-
- array set argsArray [list]
- for {set idx 0} {$idx < $argc} {incr idx} {
- set arg [lindex $args $idx]
- switch -glob -- $server,$arg $socketOptionsSwitchBody
- }
-
- set defaults $initialArgs
-}
-#
-# Helper function - behaves exactly as the native socket command.
-#
-proc tls::socket {args} {
- variable socketCmd
- variable defaults
- variable socketOptionsNoServer
- variable socketOptionsServer
- variable socketOptionsSwitchBody
-
- tls::_initsocketoptions
-
- set idx [lsearch $args -server]
- if {$idx != -1} {
- set server 1
- set callback [lindex $args [expr {$idx+1}]]
- set args [lreplace $args $idx [expr {$idx+1}]]
-
- set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
- set options $socketOptionsServer
- } else {
- set server 0
-
- set usage "wrong # args: should be \"tls::socket ?options? host port\""
- set options $socketOptionsNoServer
- }
-
- # Combine defaults with current options
- set args [concat $defaults $args]
-
- set argc [llength $args]
- set sopts {}
- set iopts [list -server $server]
-
- array set argsArray [list]
- for {set idx 0} {$idx < $argc} {incr idx} {
- set arg [lindex $args $idx]
- switch -glob -- $server,$arg $socketOptionsSwitchBody
- }
-
- if {$server} {
- if {($idx + 1) != $argc} {
- return -code error $usage
- }
- set uid [incr ::tls::srvuid]
-
- set port [lindex $args [expr {$argc-1}]]
- lappend sopts $port
- #set sopts [linsert $sopts 0 -server $callback]
- set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
- #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
- } else {
- if {($idx + 2) != $argc} {
- return -code error $usage
- }
-
- set host [lindex $args [expr {$argc-2}]]
- set port [lindex $args [expr {$argc-1}]]
-
- # If an "-autoservername" option is found, honor it
- if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
- if {![info exists argsArray(-servername)]} {
- set argsArray(-servername) $host
- lappend iopts -servername $host
- }
- }
-
- lappend sopts $host $port
- }
- #
- # Create TCP/IP socket
- #
- set chan [eval $socketCmd $sopts]
- if {!$server && [catch {
- #
- # Push SSL layer onto socket
- #
- eval [list tls::import] $chan $iopts
- } err]} {
- set info ${::errorInfo}
- catch {close $chan}
- return -code error -errorinfo $info $err
- }
- return $chan
-}
-
-# tls::_accept --
-#
-# This is the actual accept that TLS sockets use, which then calls
-# the callback registered by tls::socket.
-#
-# Arguments:
-# iopts tls::import opts
-# callback server callback to invoke
-# chan socket channel to accept/deny
-# ipaddr calling IP address
-# port calling port
-#
-# Results:
-# Returns an error if the callback throws one.
-#
-proc tls::_accept { iopts callback chan ipaddr port } {
- log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
-
- set chan [eval [list tls::import $chan] $iopts]
-
- lappend callback $chan $ipaddr $port
- if {[catch {
- uplevel #0 $callback
- } err]} {
- log 1 "tls::_accept error: ${::errorInfo}"
- close $chan
- error $err $::errorInfo $::errorCode
- } else {
- log 2 "tls::_accept - called \"$callback\" succeeded"
- }
-}
-#
-# Sample callback for hooking: -
-#
-# error
-# verify
-# info
-#
-proc tls::callback {option args} {
- variable debug
-
- #log 2 [concat $option $args]
-
- switch -- $option {
- "error" {
- foreach {chan msg} $args break
-
- log 0 "TLS/$chan: error: $msg"
- }
- "verify" {
- # poor man's lassign
- foreach {chan depth cert rc err} $args break
-
- array set c $cert
-
- if {$rc != "1"} {
- log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
- } else {
- log 2 "TLS/$chan: verify/$depth: $c(subject)"
- }
- if {$debug > 0} {
- return 1; # FORCE OK
- } else {
- return $rc
- }
- }
- "info" {
- # poor man's lassign
- foreach {chan major minor state msg} $args break
-
- if {$msg != ""} {
- append state ": $msg"
- }
- # For tracing
- upvar #0 tls::$chan cb
- set cb($major) $minor
-
- log 2 "TLS/$chan: $major/$minor: $state"
- }
- default {
- return -code error "bad option \"$option\":\
- must be one of error, info, or verify"
- }
- }
-}
-
-proc tls::xhandshake {chan} {
- upvar #0 tls::$chan cb
-
- if {[info exists cb(handshake)] && \
- $cb(handshake) == "done"} {
- return 1
- }
- while {1} {
- vwait tls::${chan}(handshake)
- if {![info exists cb(handshake)]} {
- return 0
- }
- if {$cb(handshake) == "done"} {
- return 1
- }
- }
-}
-
-proc tls::password {} {
- log 0 "TLS/Password: did you forget to set your passwd!"
- # Return the worlds best kept secret password.
- return "secret"
-}
-
-proc tls::log {level msg} {
- variable debug
- variable logcmd
-
- if {$level > $debug || $logcmd == ""} {
- return
- }
- set cmd $logcmd
- lappend cmd $msg
- uplevel #0 $cmd
-}
-
DELETED tlsBIO.c
Index: tlsBIO.c
==================================================================
--- tlsBIO.c
+++ /dev/null
@@ -1,340 +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
-
-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)", (void *) 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 = ((chan) ? Tcl_Eof(chan) : 1);
- break;
- case BIO_CTRL_PENDING:
- dprintf("Got BIO_CTRL_PENDING");
- ret = ((chan) ? ((Tcl_InputBuffered(chan) ? 1 : 0)) : 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 = ((chan) && (Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
- dprintf("BIO_CTRL_FLUSH returning value %li", ret);
- break;
- case BIO_CTRL_PUSH:
- dprintf("Got BIO_CTRL_PUSH");
- ret = 0;
- break;
- case BIO_CTRL_POP:
- dprintf("Got BIO_CTRL_POP");
- ret = 0;
- break;
- case BIO_CTRL_SET:
- dprintf("Got BIO_CTRL_SET");
- ret = 0;
- break;
- case BIO_CTRL_GET :
- dprintf("Got BIO_CTRL_GET ");
- ret = 0;
- break;
-#ifdef BIO_CTRL_GET_KTLS_SEND
- case BIO_CTRL_GET_KTLS_SEND:
- dprintf("Got BIO_CTRL_GET_KTLS_SEND");
- ret = 0;
- break;
-#endif
-#ifdef BIO_CTRL_GET_KTLS_RECV
- case BIO_CTRL_GET_KTLS_RECV:
- dprintf("Got BIO_CTRL_GET_KTLS_RECV");
- ret = 0;
- break;
-#endif
- default:
- dprintf("Got unknown control command (%i)", cmd);
- ret = 0;
- 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);
-}
-
-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);
-}
DELETED tlsIO.c
Index: tlsIO.c
==================================================================
--- tlsIO.c
+++ /dev/null
@@ -1,1004 +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 void TlsChannelHandlerTimer(ClientData clientData);
-
-/*
- * TLS Channel Type
- */
-static Tcl_ChannelType *tlsChannelType = NULL;
-
-/*
- *-------------------------------------------------------------------
- *
- * 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);
- return(0);
-
- /* Interp is unused. */
- interp = interp;
-}
-
-static int TlsCloseProc2(ClientData instanceData, Tcl_Interp *interp, int flags) {
- if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
- 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)", (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- if (*errorCodePtr == ECONNRESET) {
- *errorCodePtr = ECONNABORTED;
- }
- } else {
- dprintf("I/O error occurred (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- bytesRead = -1;
- } else {
- dprintf("I/O error occurred (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 occurred (errno = %lu)", (unsigned long) Tcl_GetErrno());
- *errorCodePtr = Tcl_GetErrno();
- written = -1;
- } else {
- dprintf("I/O error occurred (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);
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * TlsSetOptionProc --
- *
- * 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
-TlsSetOptionProc(ClientData instanceData, /* Socket state. */
- Tcl_Interp *interp, /* For errors - can be NULL. */
- const char *optionName, /* Name of the option to set the value for, or
- * NULL to get all options and their values. */
- const char *optionValue) /* Value for option. */
-{
- State *statePtr = (State *) instanceData;
-
- Tcl_Channel downChan = Tls_GetParent(statePtr, TLS_TCL_FASTPATH);
- Tcl_DriverSetOptionProc *setOptionProc;
-
- setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
- if (setOptionProc != NULL) {
- return (*setOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, optionValue);
- } 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;
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * 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. */
- 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(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) &&
- ((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 occurred 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 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));
-}
-
-/*
- *-------------------------------------------------------------------
- *
- * 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) {
- /*
- * Allocate new channeltype structure
- */
- size = sizeof(Tcl_ChannelType); /* Base size */
-
- tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
- memset((void *) tlsChannelType, 0, size);
-
- tlsChannelType->typeName = "tls";
-#ifdef TCL_CHANNEL_VERSION_5
- tlsChannelType->version = TCL_CHANNEL_VERSION_5;
- tlsChannelType->closeProc = TlsCloseProc;
- tlsChannelType->inputProc = TlsInputProc;
- tlsChannelType->outputProc = TlsOutputProc;
- tlsChannelType->seekProc = NULL;
- tlsChannelType->setOptionProc = TlsSetOptionProc;
- tlsChannelType->getOptionProc = TlsGetOptionProc;
- tlsChannelType->watchProc = TlsWatchProc;
- tlsChannelType->getHandleProc = TlsGetHandleProc;
- tlsChannelType->close2Proc = TlsCloseProc2;
- tlsChannelType->blockModeProc = TlsBlockModeProc;
- tlsChannelType->flushProc = NULL;
- tlsChannelType->handlerProc = TlsNotifyProc;
- tlsChannelType->wideSeekProc = NULL;
- tlsChannelType->threadActionProc= NULL;
- tlsChannelType->truncateProc = NULL;
-#else
- tlsChannelType->version = TCL_CHANNEL_VERSION_2;
- tlsChannelType->closeProc = TlsCloseProc;
- tlsChannelType->inputProc = TlsInputProc;
- tlsChannelType->outputProc = TlsOutputProc;
- tlsChannelType->seekProc = NULL;
- tlsChannelType->setOptionProc = TlsSetOptionProc;
- tlsChannelType->getOptionProc = TlsGetOptionProc;
- tlsChannelType->watchProc = TlsWatchProc;
- tlsChannelType->getHandleProc = TlsGetHandleProc;
- tlsChannelType->close2Proc = NULL;
- tlsChannelType->blockModeProc = TlsBlockModeProc;
- tlsChannelType->flushProc = NULL;
- tlsChannelType->handlerProc = TlsNotifyProc;
-#endif
- }
- return(tlsChannelType);
-}
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 TCL 8.6 CONST changes */
-#ifndef CONST86
-#define CONST86
-#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,216 +0,0 @@
-/*
- * Copyright (C) 1997-2000 Sensus Consulting Ltd.
- * Matt Newman
- */
-#include
-#include
-#include
-#include
-#include
-#include
-#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( 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
- char sha1_hash_ascii[SHA_DIGEST_LENGTH * 2 + 1];
- unsigned char sha1_hash_binary[SHA_DIGEST_LENGTH];
- char sha256_hash_ascii[SHA256_DIGEST_LENGTH * 2 + 1];
- unsigned char sha256_hash_binary[SHA256_DIGEST_LENGTH];
- const char *shachars="0123456789ABCDEF";
-
- sha1_hash_ascii[SHA_DIGEST_LENGTH * 2] = '\0';
- sha256_hash_ascii[SHA256_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);
- }
-
-#if OPENSSL_VERSION_NUMBER < 0x10100000L
- strcpy( notBefore, ASN1_UTCTIME_tostr( X509_get_notBefore(cert) ));
- strcpy( notAfter, ASN1_UTCTIME_tostr( X509_get_notAfter(cert) ));
-#else
- strcpy( notBefore, ASN1_UTCTIME_tostr( X509_getm_notBefore(cert) ));
- strcpy( notAfter, ASN1_UTCTIME_tostr( X509_getm_notAfter(cert) ));
-#endif
-
-#ifndef NO_SSL_SHA
- /* SHA1 */
- X509_digest(cert, EVP_sha1(), sha1_hash_binary, NULL);
- for (int n = 0; n < SHA_DIGEST_LENGTH; n++) {
- sha1_hash_ascii[n*2] = shachars[(sha1_hash_binary[n] & 0xF0) >> 4];
- sha1_hash_ascii[n*2+1] = shachars[(sha1_hash_binary[n] & 0x0F)];
- }
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj("sha1_hash", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj(sha1_hash_ascii, SHA_DIGEST_LENGTH * 2) );
-
- /* SHA256 */
- X509_digest(cert, EVP_sha256(), sha256_hash_binary, NULL);
- for (int n = 0; n < SHA256_DIGEST_LENGTH; n++) {
- sha256_hash_ascii[n*2] = shachars[(sha256_hash_binary[n] & 0xF0) >> 4];
- sha256_hash_ascii[n*2+1] = shachars[(sha256_hash_binary[n] & 0x0F)];
- }
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( "sha256_hash", -1) );
- Tcl_ListObjAppendElement( interp, certPtr, Tcl_NewStringObj( sha256_hash_ascii, SHA256_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,86 @@
Windows DLL Build instructions using nmake build system
2020-10-15 Harald.Oehlmann@elmicron.de
+ 2023-04-23 Brian O'Hagan
Properties:
-- 32 bit DLL
+- 64 bit DLL
- VisualStudio 2015
-Note: Vuisual C++ 6 does not build OpenSSL (long long syntax error)
+Note: Visual 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
+Note: Dynamic linking also works but results in a DLL dependency 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
+set SSLBUILD=\path\to\build\dir
+set SSLINSTALL=\path\to\install\dir
+set SSLCOMMON=\path\to\common\dir
+
+(1a) Get OpenSSL
+
+ https://github.com/openssl/openssl/releases/download/OpenSSL_1_1_1t/openssl-1.1.1t.tar.gz
+
+ Unpack OpenSSL source distribution to %SSLBUILD%
+
+(1b) Install Perl from https://strawberryperl.com/
+
+ https://strawberryperl.com/download/5.32.1.1/strawberry-perl-5.32.1.1-64bit.msi
+ Install to C:\Strawberry\perl
+
+(1c) Install NASM Assembler from https://www.nasm.us/
+
+ https://www.nasm.us/pub/nasm/releasebuilds/2.16.01/win64/nasm-2.16.01-installer-x64.exe
+ Install to: C:\Program Files\NASM
+
+(1d) Configure
+
+ At Visual Studio x86 native prompt:
+
+ set Path=%PATH%;C:\Program Files\NASM;C:\Strawberry\perl\bin
+ perl ..\Configure VC-WIN64A no-shared no-filenames threads no-ssl2 no-ssl3 --api=1.1.0 --prefix="%SSLINSTALL%" --openssldir="%SSLCOMMON%" -DOPENSSL_NO_DEPRECATED
+ # Not used options: no-asm no-zlib no-comp no-ui-console no-autoload-config
+
+(1e) Build OpenSSL
+
+ nmake
+ nmake test
+ nmake install
+
+-----------------------------
+
+2) Build TclTLS
+
+set BUILDDIR=\path\to\build\dir
+set TCLINSTALL=\path\to\tcl\dir
+
+2a) Unzip distribution to %BUILDDIR%
+
+2b) Start BASH shell (MinGW62 Git shell)
+
+cd %BUILDDIR%
./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
+od -A n -v -t xC < 'library/tls.tcl' > tls.tcl.h.new.1
+sed 's@[^0-9A-Fa-f]@@g;s@..@0x&, @g' < tls.tcl.h.new.1 > generic/tls.tcl.h
rm -f tls.tcl.h.new.1
--> Visual Studio x86 native prompt.
+2c) Start Visual Studio shell
+
+cd %BUILDDIR%\win
-cd C:\test\tcltls\tcltls-1.7.22\win
+nmake -f makefile.vc TCLDIR=%TCLINSTALL% SSL_INSTALL_FOLDER=%SSLINSTALL%
+nmake -f makefile.vc install TCLDIR=c:\test\tcl8610 INSTALLDIR=%TCLINSTALL% SSL_INSTALL_FOLDER=%SSLINSTALL%
-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...
+package require http
+http::register https 443 [list ::tls::socket -autoservername true]
+set tok [http::data [http::geturl https://www.tcl-lang.org]]
+::http::cleanup $tok
Index: win/makefile.vc
==================================================================
--- win/makefile.vc
+++ win/makefile.vc
@@ -1,13 +1,23 @@
# call nmake with additional parameter SSL_INSTALL_FOLDER= with the
-# OpenSSL instalation folder following.
+# OpenSSL installation folder following.
PROJECT=tls
DOTVERSION = 1.7.22
-PRJ_INCLUDES = -I"$(SSL_INSTALL_FOLDER)\include"
-PRJ_DEFINES = -D NO_SSL2 -D NO_SSL3 -D _CRT_SECURE_NO_WARNINGS
+PRJ_INCLUDES = -I"$(SSL_INSTALL_FOLDER)\include" -I"$(OPENSSL_INSTALL_DIR)\include"
+
+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
@@ -18,7 +28,10 @@
$(TMP_DIR)\tlsX509.obj
!include "rules-ext.vc"
!include "targets.vc"
-pkgindex: default-pkgindex
+# Project specific targets
+pkgindex: default-pkgindex
+install: default-pkgindex-tea default-install default-install-docs-html
+test: default-test
ADDED win/nmakehlp.c
Index: win/nmakehlp.c
==================================================================
--- /dev/null
+++ win/nmakehlp.c
@@ -0,0 +1,815 @@
+/*
+ * ----------------------------------------------------------------------------
+ * nmakehlp.c --
+ *
+ * This is used to fix limitations within nmake and the environment.
+ *
+ * Copyright (c) 2002 by David Gravereaux.
+ * Copyright (c) 2006 by Pat Thoyts
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * ----------------------------------------------------------------------------
+ */
+
+#define _CRT_SECURE_NO_DEPRECATE
+#include
+#ifdef _MSC_VER
+#pragma comment (lib, "user32.lib")
+#pragma comment (lib, "kernel32.lib")
+#endif
+#include
+#include
+
+/*
+ * This library is required for x64 builds with _some_ versions of MSVC
+ */
+#if defined(_M_IA64) || defined(_M_AMD64)
+#if _MSC_VER >= 1400 && _MSC_VER < 1500
+#pragma comment(lib, "bufferoverflowU")
+#endif
+#endif
+
+/* ISO hack for dumb VC++ */
+#ifdef _MSC_VER
+#define snprintf _snprintf
+#endif
+
+
+/* protos */
+
+static int CheckForCompilerFeature(const char *option);
+static int CheckForLinkerFeature(char **options, int count);
+static int IsIn(const char *string, const char *substring);
+static int SubstituteFile(const char *substs, const char *filename);
+static int QualifyPath(const char *path);
+static int LocateDependency(const char *keyfile);
+static const char *GetVersionFromFile(const char *filename, const char *match, int numdots);
+static DWORD WINAPI ReadFromPipe(LPVOID args);
+
+/* globals */
+
+#define CHUNK 25
+#define STATICBUFFERSIZE 1000
+typedef struct {
+ HANDLE pipe;
+ char buffer[STATICBUFFERSIZE];
+} pipeinfo;
+
+pipeinfo Out = {INVALID_HANDLE_VALUE, ""};
+pipeinfo Err = {INVALID_HANDLE_VALUE, ""};
+
+/*
+ * exitcodes: 0 == no, 1 == yes, 2 == error
+ */
+
+int
+main(
+ int argc,
+ char *argv[])
+{
+ char msg[300];
+ DWORD dwWritten;
+ int chars;
+ const char *s;
+
+ /*
+ * Make sure children (cl.exe and link.exe) are kept quiet.
+ */
+
+ SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX);
+
+ /*
+ * Make sure the compiler and linker aren't effected by the outside world.
+ */
+
+ SetEnvironmentVariable("CL", "");
+ SetEnvironmentVariable("LINK", "");
+
+ if (argc > 1 && *argv[1] == '-') {
+ switch (*(argv[1]+1)) {
+ case 'c':
+ if (argc != 3) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -c \n"
+ "Tests for whether cl.exe supports an option\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return CheckForCompilerFeature(argv[2]);
+ case 'l':
+ if (argc < 3) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -l ? ...?\n"
+ "Tests for whether link.exe supports an option\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return CheckForLinkerFeature(&argv[2], argc-2);
+ case 'f':
+ if (argc == 2) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -f \n"
+ "Find a substring within another\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ } else if (argc == 3) {
+ /*
+ * If the string is blank, there is no match.
+ */
+
+ return 0;
+ } else {
+ return IsIn(argv[2], argv[3]);
+ }
+ case 's':
+ if (argc == 2) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -s \n"
+ "Perform a set of string map type substutitions on a file\n"
+ "exitcodes: 0\n",
+ argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return SubstituteFile(argv[2], argv[3]);
+ case 'V':
+ if (argc != 4) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -V filename matchstring\n"
+ "Extract a version from a file:\n"
+ "eg: pkgIndex.tcl \"package ifneeded http\"",
+ argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 0;
+ }
+ s = GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0');
+ if (s && *s) {
+ printf("%s\n", s);
+ return 0;
+ } else
+ return 1; /* Version not found. Return non-0 exit code */
+
+ case 'Q':
+ if (argc != 3) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -Q path\n"
+ "Emit the fully qualified path\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return QualifyPath(argv[2]);
+
+ case 'L':
+ if (argc != 3) {
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -L keypath\n"
+ "Emit the fully qualified path of directory containing keypath\n"
+ "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
+ &dwWritten, NULL);
+ return 2;
+ }
+ return LocateDependency(argv[2]);
+ }
+ }
+ chars = snprintf(msg, sizeof(msg) - 1,
+ "usage: %s -c|-f|-l|-Q|-s|-V ...\n"
+ "This is a little helper app to equalize shell differences between WinNT and\n"
+ "Win9x and get nmake.exe to accomplish its job.\n",
+ argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 2;
+}
+
+static int
+CheckForCompilerFeature(
+ const char *option)
+{
+ STARTUPINFO si;
+ PROCESS_INFORMATION pi;
+ SECURITY_ATTRIBUTES sa;
+ DWORD threadID;
+ char msg[300];
+ BOOL ok;
+ HANDLE hProcess, h, pipeThreads[2];
+ char cmdline[100];
+
+ hProcess = GetCurrentProcess();
+
+ ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+ si.cb = sizeof(STARTUPINFO);
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = INVALID_HANDLE_VALUE;
+
+ ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
+ sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sa.lpSecurityDescriptor = NULL;
+ sa.bInheritHandle = FALSE;
+
+ /*
+ * Create a non-inheritible pipe.
+ */
+
+ CreatePipe(&Out.pipe, &h, &sa, 0);
+
+ /*
+ * Dupe the write side, make it inheritible, and close the original.
+ */
+
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
+ DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /*
+ * Same as above, but for the error side.
+ */
+
+ CreatePipe(&Err.pipe, &h, &sa, 0);
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
+ DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /*
+ * Base command line.
+ */
+
+ lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch ");
+
+ /*
+ * Append our option for testing
+ */
+
+ lstrcat(cmdline, option);
+
+ /*
+ * Filename to compile, which exists, but is nothing and empty.
+ */
+
+ lstrcat(cmdline, " .\\nul");
+
+ ok = CreateProcess(
+ NULL, /* Module name. */
+ cmdline, /* Command line. */
+ NULL, /* Process handle not inheritable. */
+ NULL, /* Thread handle not inheritable. */
+ TRUE, /* yes, inherit handles. */
+ DETACHED_PROCESS, /* No console for you. */
+ NULL, /* Use parent's environment block. */
+ NULL, /* Use parent's starting directory. */
+ &si, /* Pointer to STARTUPINFO structure. */
+ &pi); /* Pointer to PROCESS_INFORMATION structure. */
+
+ if (!ok) {
+ DWORD err = GetLastError();
+ int chars = snprintf(msg, sizeof(msg) - 1,
+ "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
+
+ FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
+ FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
+ (300-chars), 0);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
+ return 2;
+ }
+
+ /*
+ * Close our references to the write handles that have now been inherited.
+ */
+
+ CloseHandle(si.hStdOutput);
+ CloseHandle(si.hStdError);
+
+ WaitForInputIdle(pi.hProcess, 5000);
+ CloseHandle(pi.hThread);
+
+ /*
+ * Start the pipe reader threads.
+ */
+
+ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
+ pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
+
+ /*
+ * Block waiting for the process to end.
+ */
+
+ WaitForSingleObject(pi.hProcess, INFINITE);
+ CloseHandle(pi.hProcess);
+
+ /*
+ * Wait for our pipe to get done reading, should it be a little slow.
+ */
+
+ WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
+ CloseHandle(pipeThreads[0]);
+ CloseHandle(pipeThreads[1]);
+
+ /*
+ * Look for the commandline warning code in both streams.
+ * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
+ */
+
+ return !(strstr(Out.buffer, "D4002") != NULL
+ || strstr(Err.buffer, "D4002") != NULL
+ || strstr(Out.buffer, "D9002") != NULL
+ || strstr(Err.buffer, "D9002") != NULL
+ || strstr(Out.buffer, "D2021") != NULL
+ || strstr(Err.buffer, "D2021") != NULL);
+}
+
+static int
+CheckForLinkerFeature(
+ char **options,
+ int count)
+{
+ STARTUPINFO si;
+ PROCESS_INFORMATION pi;
+ SECURITY_ATTRIBUTES sa;
+ DWORD threadID;
+ char msg[300];
+ BOOL ok;
+ HANDLE hProcess, h, pipeThreads[2];
+ int i;
+ char cmdline[255];
+
+ hProcess = GetCurrentProcess();
+
+ ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+ si.cb = sizeof(STARTUPINFO);
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = INVALID_HANDLE_VALUE;
+
+ ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
+ sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sa.lpSecurityDescriptor = NULL;
+ sa.bInheritHandle = TRUE;
+
+ /*
+ * Create a non-inheritible pipe.
+ */
+
+ CreatePipe(&Out.pipe, &h, &sa, 0);
+
+ /*
+ * Dupe the write side, make it inheritible, and close the original.
+ */
+
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
+ DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /*
+ * Same as above, but for the error side.
+ */
+
+ CreatePipe(&Err.pipe, &h, &sa, 0);
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
+ DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /*
+ * Base command line.
+ */
+
+ lstrcpy(cmdline, "link.exe -nologo ");
+
+ /*
+ * Append our option for testing.
+ */
+
+ for (i = 0; i < count; i++) {
+ lstrcat(cmdline, " \"");
+ lstrcat(cmdline, options[i]);
+ lstrcat(cmdline, "\"");
+ }
+
+ ok = CreateProcess(
+ NULL, /* Module name. */
+ cmdline, /* Command line. */
+ NULL, /* Process handle not inheritable. */
+ NULL, /* Thread handle not inheritable. */
+ TRUE, /* yes, inherit handles. */
+ DETACHED_PROCESS, /* No console for you. */
+ NULL, /* Use parent's environment block. */
+ NULL, /* Use parent's starting directory. */
+ &si, /* Pointer to STARTUPINFO structure. */
+ &pi); /* Pointer to PROCESS_INFORMATION structure. */
+
+ if (!ok) {
+ DWORD err = GetLastError();
+ int chars = snprintf(msg, sizeof(msg) - 1,
+ "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
+
+ FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
+ FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars],
+ (300-chars), 0);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
+ return 2;
+ }
+
+ /*
+ * Close our references to the write handles that have now been inherited.
+ */
+
+ CloseHandle(si.hStdOutput);
+ CloseHandle(si.hStdError);
+
+ WaitForInputIdle(pi.hProcess, 5000);
+ CloseHandle(pi.hThread);
+
+ /*
+ * Start the pipe reader threads.
+ */
+
+ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
+ pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
+
+ /*
+ * Block waiting for the process to end.
+ */
+
+ WaitForSingleObject(pi.hProcess, INFINITE);
+ CloseHandle(pi.hProcess);
+
+ /*
+ * Wait for our pipe to get done reading, should it be a little slow.
+ */
+
+ WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
+ CloseHandle(pipeThreads[0]);
+ CloseHandle(pipeThreads[1]);
+
+ /*
+ * Look for the commandline warning code in the stderr stream.
+ */
+
+ return !(strstr(Out.buffer, "LNK1117") != NULL ||
+ strstr(Err.buffer, "LNK1117") != NULL ||
+ strstr(Out.buffer, "LNK4044") != NULL ||
+ strstr(Err.buffer, "LNK4044") != NULL ||
+ strstr(Out.buffer, "LNK4224") != NULL ||
+ strstr(Err.buffer, "LNK4224") != NULL);
+}
+
+static DWORD WINAPI
+ReadFromPipe(
+ LPVOID args)
+{
+ pipeinfo *pi = (pipeinfo *) args;
+ char *lastBuf = pi->buffer;
+ DWORD dwRead;
+ BOOL ok;
+
+ again:
+ if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) {
+ CloseHandle(pi->pipe);
+ return (DWORD)-1;
+ }
+ ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L);
+ if (!ok || dwRead == 0) {
+ CloseHandle(pi->pipe);
+ return 0;
+ }
+ lastBuf += dwRead;
+ goto again;
+
+ return 0; /* makes the compiler happy */
+}
+
+static int
+IsIn(
+ const char *string,
+ const char *substring)
+{
+ return (strstr(string, substring) != NULL);
+}
+
+/*
+ * GetVersionFromFile --
+ * Looks for a match string in a file and then returns the version
+ * following the match where a version is anything acceptable to
+ * package provide or package ifneeded.
+ */
+
+static const char *
+GetVersionFromFile(
+ const char *filename,
+ const char *match,
+ int numdots)
+{
+ static char szBuffer[100];
+ char *szResult = NULL;
+ FILE *fp = fopen(filename, "rt");
+
+ if (fp != NULL) {
+ /*
+ * Read data until we see our match string.
+ */
+
+ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
+ LPSTR p, q;
+
+ p = strstr(szBuffer, match);
+ if (p != NULL) {
+ /*
+ * Skip to first digit after the match.
+ */
+
+ p += strlen(match);
+ while (*p && !isdigit((unsigned char)*p)) {
+ ++p;
+ }
+
+ /*
+ * Find ending whitespace.
+ */
+
+ q = p;
+ while (*q && (strchr("0123456789.ab", *q)) && (((!strchr(".ab", *q)
+ && !strchr("ab", q[-1])) || --numdots))) {
+ ++q;
+ }
+
+ *q = 0;
+ szResult = p;
+ break;
+ }
+ }
+ fclose(fp);
+ }
+ return szResult;
+}
+
+/*
+ * List helpers for the SubstituteFile function
+ */
+
+typedef struct list_item_t {
+ struct list_item_t *nextPtr;
+ char * key;
+ char * value;
+} list_item_t;
+
+/* insert a list item into the list (list may be null) */
+static list_item_t *
+list_insert(list_item_t **listPtrPtr, const char *key, const char *value)
+{
+ list_item_t *itemPtr = (list_item_t *)malloc(sizeof(list_item_t));
+ if (itemPtr) {
+ itemPtr->key = strdup(key);
+ itemPtr->value = strdup(value);
+ itemPtr->nextPtr = NULL;
+
+ while(*listPtrPtr) {
+ listPtrPtr = &(*listPtrPtr)->nextPtr;
+ }
+ *listPtrPtr = itemPtr;
+ }
+ return itemPtr;
+}
+
+static void
+list_free(list_item_t **listPtrPtr)
+{
+ list_item_t *tmpPtr, *listPtr = *listPtrPtr;
+ while (listPtr) {
+ tmpPtr = listPtr;
+ listPtr = listPtr->nextPtr;
+ free(tmpPtr->key);
+ free(tmpPtr->value);
+ free(tmpPtr);
+ }
+}
+
+/*
+ * SubstituteFile --
+ * As windows doesn't provide anything useful like sed and it's unreliable
+ * to use the tclsh you are building against (consider x-platform builds -
+ * eg compiling AMD64 target from IX86) we provide a simple substitution
+ * option here to handle autoconf style substitutions.
+ * The substitution file is whitespace and line delimited. The file should
+ * consist of lines matching the regular expression:
+ * \s*\S+\s+\S*$
+ *
+ * Usage is something like:
+ * nmakehlp -S << $** > $@
+ * @PACKAGE_NAME@ $(PACKAGE_NAME)
+ * @PACKAGE_VERSION@ $(PACKAGE_VERSION)
+ * <<
+ */
+
+static int
+SubstituteFile(
+ const char *substitutions,
+ const char *filename)
+{
+ static char szBuffer[1024], szCopy[1024];
+ list_item_t *substPtr = NULL;
+ FILE *fp, *sp;
+
+ fp = fopen(filename, "rt");
+ if (fp != NULL) {
+
+ /*
+ * Build a list of substutitions from the first filename
+ */
+
+ sp = fopen(substitutions, "rt");
+ if (sp != NULL) {
+ while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) {
+ unsigned char *ks, *ke, *vs, *ve;
+ ks = (unsigned char*)szBuffer;
+ while (ks && *ks && isspace(*ks)) ++ks;
+ ke = ks;
+ while (ke && *ke && !isspace(*ke)) ++ke;
+ vs = ke;
+ while (vs && *vs && isspace(*vs)) ++vs;
+ ve = vs;
+ while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve;
+ *ke = 0, *ve = 0;
+ list_insert(&substPtr, (char*)ks, (char*)vs);
+ }
+ fclose(sp);
+ }
+
+ /* debug: dump the list */
+#ifndef NDEBUG
+ {
+ int n = 0;
+ list_item_t *p = NULL;
+ for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
+ fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
+ }
+ }
+#endif
+
+ /*
+ * Run the substitutions over each line of the input
+ */
+
+ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) {
+ list_item_t *p = NULL;
+ for (p = substPtr; p != NULL; p = p->nextPtr) {
+ char *m = strstr(szBuffer, p->key);
+ if (m) {
+ char *cp, *op, *sp;
+ cp = szCopy;
+ op = szBuffer;
+ while (op != m) *cp++ = *op++;
+ sp = p->value;
+ while (sp && *sp) *cp++ = *sp++;
+ op += strlen(p->key);
+ while (*op) *cp++ = *op++;
+ *cp = 0;
+ memcpy(szBuffer, szCopy, sizeof(szCopy));
+ }
+ }
+ printf("%s", szBuffer);
+ }
+
+ list_free(&substPtr);
+ }
+ fclose(fp);
+ return 0;
+}
+
+BOOL FileExists(LPCTSTR szPath)
+{
+#ifndef INVALID_FILE_ATTRIBUTES
+ #define INVALID_FILE_ATTRIBUTES ((DWORD)-1)
+#endif
+ DWORD pathAttr = GetFileAttributes(szPath);
+ return (pathAttr != INVALID_FILE_ATTRIBUTES &&
+ !(pathAttr & FILE_ATTRIBUTE_DIRECTORY));
+}
+
+
+/*
+ * QualifyPath --
+ *
+ * This composes the current working directory with a provided path
+ * and returns the fully qualified and normalized path.
+ * Mostly needed to setup paths for testing.
+ */
+
+static int
+QualifyPath(
+ const char *szPath)
+{
+ char szCwd[MAX_PATH + 1];
+
+ GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
+ printf("%s\n", szCwd);
+ return 0;
+}
+
+/*
+ * Implements LocateDependency for a single directory. See that command
+ * for an explanation.
+ * Returns 0 if found after printing the directory.
+ * Returns 1 if not found but no errors.
+ * Returns 2 on any kind of error
+ * Basically, these are used as exit codes for the process.
+ */
+static int LocateDependencyHelper(const char *dir, const char *keypath)
+{
+ HANDLE hSearch;
+ char path[MAX_PATH+1];
+ size_t dirlen;
+ int keylen, ret;
+ WIN32_FIND_DATA finfo;
+
+ if (dir == NULL || keypath == NULL)
+ return 2; /* Have no real error reporting mechanism into nmake */
+ dirlen = strlen(dir);
+ if ((dirlen + 3) > sizeof(path))
+ return 2;
+ strncpy(path, dir, dirlen);
+ strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */
+ keylen = strlen(keypath);
+
+#if 0 /* This function is not available in Visual C++ 6 */
+ /*
+ * Use numerics 0 -> FindExInfoStandard,
+ * 1 -> FindExSearchLimitToDirectories,
+ * as these are not defined in Visual C++ 6
+ */
+ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0);
+#else
+ hSearch = FindFirstFile(path, &finfo);
+#endif
+ if (hSearch == INVALID_HANDLE_VALUE)
+ return 1; /* Not found */
+
+ /* Loop through all subdirs checking if the keypath is under there */
+ ret = 1; /* Assume not found */
+ do {
+ int sublen;
+ /*
+ * We need to check it is a directory despite the
+ * FindExSearchLimitToDirectories in the above call. See SDK docs
+ */
+ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0)
+ continue;
+ sublen = strlen(finfo.cFileName);
+ if ((dirlen+1+sublen+1+keylen+1) > sizeof(path))
+ continue; /* Path does not fit, assume not matched */
+ strncpy(path+dirlen+1, finfo.cFileName, sublen);
+ path[dirlen+1+sublen] = '\\';
+ strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
+ if (FileExists(path)) {
+ /* Found a match, print to stdout */
+ path[dirlen+1+sublen] = '\0';
+ QualifyPath(path);
+ ret = 0;
+ break;
+ }
+ } while (FindNextFile(hSearch, &finfo));
+ FindClose(hSearch);
+ return ret;
+}
+
+/*
+ * LocateDependency --
+ *
+ * Locates a dependency for a package.
+ * keypath - a relative path within the package directory
+ * that is used to confirm it is the correct directory.
+ * The search path for the package directory is currently only
+ * the parent and grandparent of the current working directory.
+ * If found, the command prints
+ * name_DIRPATH=
+ * and returns 0. If not found, does not print anything and returns 1.
+ */
+static int LocateDependency(const char *keypath)
+{
+ size_t i;
+ int ret;
+ static const char *paths[] = {"..", "..\\..", "..\\..\\.."};
+
+ for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) {
+ ret = LocateDependencyHelper(paths[i], keypath);
+ if (ret == 0)
+ return ret;
+ }
+ return ret;
+}
+
+
+/*
+ * Local variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * indent-tabs-mode: t
+ * tab-width: 8
+ * End:
+ */
ADDED win/rules-ext.vc
Index: win/rules-ext.vc
==================================================================
--- /dev/null
+++ win/rules-ext.vc
@@ -0,0 +1,118 @@
+# 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 [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul]
+!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,1885 @@
+#------------------------------------------------------------- -*- 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. Parse the OPTS macro value for user-specified build configuration
+# 7. Parse the STATS macro value for statistics instrumentation
+# 8. Parse the CHECKS macro for additional compilation checks
+# 9. Extract Tcl, and possibly Tk, version numbers from the headers
+# 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)
+# TCL_UTF_MAX=3 - forces a build using UTF-16 internally (not recommended).
+# 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
+
+!if [nmakehlp -f $(OPTS) "utf16"]
+!message *** Force UTF-16 internally
+TCL_UTF_MAX = 3
+!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)
+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
+TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT)
+TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib
+TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
+
+!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
+PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
+PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+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 opttions
+# 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_UTF_MAX)" == "3"
+OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3
+!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)
+
+# 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) \
+ /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 package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+!else
+default-pkgindex:
+ @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PRJLIBNAME)]] > $(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)
+<<
+
+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
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)