Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -11,28 +11,29 @@

tls - binding to OpenSSL - toolkit.

- +

tls - binding to OpenSSL toolkit.

SYNOPSIS

package require Tcl ?8.4?; package require tls ?@@VERS@@?; package require Tcl ?8.4?; package require tls
: tls::init ?options?; tls::socket ?options? host port; tls::socket ?-server command? ?options? port; tls::handshake channel; tls::status ?-local? channel; tls::connection channel; tls::import channel ?options?; tls::unimport channel
: 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::ciphers protocol ?verbose? ?supported?; tls::protocols; tls::version

COMMANDS

CALLBACK OPTIONS

@@ -49,23 +50,23 @@ 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::status ?-local? channel
-tls::handshake channel
-
-tls::import channel ?options?
-tls::unimport channel
-tls::ciphers -protocol ?verbose?
+package require tls
+
+tls::init ?options?
+tls::socket ?options? host port
+tls::socket ?-server command? ?options? port
+tls::status ?-local? channel
+tls::connection channel
+tls::handshake channel
+tls::import channel ?options?
+tls::unimport channel
+
+tls::ciphers protocol ?verbose? ?supported?
+tls::protocols tls::version

DESCRIPTION

@@ -84,12 +85,12 @@ 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 +; Optional function to set the default options used by + tls::socket. 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::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.
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::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 +; Returns the current certificate 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 @@ -154,123 +248,68 @@
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
+ SSLv2, SSLv3, TLSv1, TLSv1.1, TLSv1.2, TLSv1.3, or 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.

tls::connection + channel

Returns the current connection status of an SSL channel. The + result is a list of key-value pairs describing the + connected peer.

-
-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)
+
state state
+
State of the connection: initializing, handshake, established
+
server name
+
The name of the connected to server.
+
protocol version
+
The protocol version used for the connection: + SSL2, SSL3, TLS1, TLS1.1, TLS1.2, TLS1.3, or unknown
+
cipher cipher
+
The current cipher in use for the connection.
+
standard_name name
+
The standard RFC name of cipher.
+
bits n
+
The number of processed bits used for cipher.
+
secret_bits n
+
The number of secret bits used for cipher.
+
min_version version
+
The minimum protocol version for cipher.
+
description string
+
A text description of the cipher.
+
renegotiation state
+
Whether protocol renegotiation is allowed or disallowed.
+
alpn protocol
+
The protocol selected after Application-Layer Protocol + Negotiation (ALPN).
+
session_reused boolean
+
Whether the session has been reused or not.

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::ciphers + protocol ?verbose? ?supported?: Returns a list of supported ciphers available for protocol, + where protocol must be one of ssl2, ssl3, tls1, tls1.1, + tls1.2, or tls1.3. If verbose is specified as + true then a verbose, human readable list is returned with + additional information on the cipher. If supported + is specified as true, then only the ciphers supported for protocol + will be listed.
tls::protocols: Returns a list of supported protocols. Valid values are: + ssl2, ssl3, tls1, tls1.1, tls1.2, + and tls1.3.
tls::version: Returns the version string defined by OpenSSL.; Returns the OpenSSL version string.

Index: generic/tls.c ================================================================== --- generic/tls.c +++ generic/tls.c @@ -2,10 +2,11 @@ * Copyright (C) 1997-1999 Matt Newman * some modifications: * Copyright (C) 2000 Ajuba Solutions * Copyright (C) 2002 ActiveState Corporation * Copyright (C) 2004 Starfish Systems + * Copyright (C) 2023 Brian O'Hagan * * 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 @@ -488,40 +489,45 @@ * Side effects: * constructs and destroys SSL context (CTX) * *------------------------------------------------------------------- */ +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 +}; + 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; + Tcl_Obj *objPtr = NULL; SSL_CTX *ctx = NULL; SSL *ssl = NULL; STACK_OF(SSL_CIPHER) *sk; char *cp, buf[BUFSIZ]; - int index, verbose = 0; + int index, verbose = 0, use_supported = 0; dprintf("Called"); - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?"); + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose? ?supported?"); 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; } + if ((objc > 3) && Tcl_GetBooleanFromObj(interp, objv[3], &use_supported) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum protocol)index) { case TLS_SSL2: -#if OPENSSL_VERSION_NUMBER >= 0x10101000L || defined(NO_SSL2) || defined(OPENSSL_NO_SSL2) +#if OPENSSL_VERSION_NUMBER >= 0x10100000L || 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 @@ -568,42 +574,111 @@ } 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)); - } + + /* Use list and order as would be sent in a ClientHello or all available ciphers */ + if (use_supported) { + sk = SSL_get1_supported_ciphers(ssl); } 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'; + if (sk != NULL) { + if (!verbose) { + objPtr = Tcl_NewListObj(0, NULL); + for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) { + const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i); + if (c == NULL) continue; + + /* cipher name or (NONE) */ + cp = SSL_CIPHER_get_name(c); + if (cp == NULL) break; + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(cp, -1)); + } + + } else { + objPtr = Tcl_NewStringObj("",0); + for (int i = 0; i < sk_SSL_CIPHER_num(sk); i++) { + const SSL_CIPHER *c = sk_SSL_CIPHER_value(sk, i); + if (c == NULL) continue; + + /* textual description of the cipher */ + if (SSL_CIPHER_description(c, buf, sizeof(buf)) != NULL) { + Tcl_AppendToObj(objPtr, buf, strlen(buf)); } else { - break; + Tcl_AppendToObj(objPtr, "UNKNOWN\n", 8); } } - Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1)); + } + if (use_supported) { + sk_SSL_CIPHER_free(sk); } } SSL_free(ssl); SSL_CTX_free(ctx); + + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; + clientData = clientData; +} + +/* + *------------------------------------------------------------------- + * + * ProtocolsObjCmd -- list available protocols + * + * This procedure is invoked to process the "tls::protocols" command + * to list available protocols. + * + * Results: + * A standard Tcl result list. + * + * Side effects: + * none + * + *------------------------------------------------------------------- + */ +static int +ProtocolsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { + Tcl_Obj *objPtr; + + dprintf("Called"); + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + objPtr = Tcl_NewListObj(0, NULL); + +#if OPENSSL_VERSION_NUMBER < 0x10100000L && !defined(NO_SSL2) && !defined(OPENSSL_NO_SSL2) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL2], -1)); +#endif +#if !defined(NO_SSL3) && !defined(OPENSSL_NO_SSL3) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_SSL3], -1)); +#endif +#if !defined(NO_TLS1) && !defined(OPENSSL_NO_TLS1) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1], -1)); +#endif +#if !defined(NO_TLS1_1) && !defined(OPENSSL_NO_TLS1_1) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_1], -1)); +#endif +#if !defined(NO_TLS1_2) && !defined(OPENSSL_NO_TLS1_2) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_2], -1)); +#endif +#if !defined(NO_TLS1_3) && !defined(OPENSSL_NO_TLS1_3) + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(protocols[TLS_TLS1_3], -1)); +#endif Tcl_SetObjResult(interp, objPtr); return TCL_OK; clientData = clientData; } @@ -935,11 +1010,11 @@ } } if (alpn) { /* Convert a Tcl list into a protocol-list in wire-format */ unsigned char *protos, *p; - unsigned int protoslen = 0; + unsigned int protos_len = 0; int i, len, cnt; Tcl_Obj **list; if (Tcl_ListObjGetElements(interp, alpn, &cnt, &list) != TCL_OK) { Tls_Free((char *) statePtr); return TCL_ERROR; @@ -950,23 +1025,23 @@ if (len > 255) { Tcl_AppendResult(interp, "alpn protocol name too long", (char *) NULL); Tls_Free((char *) statePtr); return TCL_ERROR; } - protoslen += 1 + len; + protos_len += 1 + len; } /* Build the complete protocol-list */ - protos = ckalloc(protoslen); + protos = ckalloc(protos_len); /* 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)) { + if (SSL_set_alpn_protos(statePtr->ssl, protos, protos_len)) { Tcl_AppendResult(interp, "failed to set alpn protocols", (char *) NULL); Tls_Free((char *) statePtr); ckfree(protos); return TCL_ERROR; } @@ -1471,10 +1546,136 @@ } /* *------------------------------------------------------------------- * + * ConnectionInfoObjCmd -- return connection info from OpenSSL. + * + * Results: + * A list of connection info + * + *------------------------------------------------------------------- + */ + +static int ConnectionInfoObjCmd(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 */ + Tcl_Obj *objPtr; + const SSL *ssl; + const SSL_CIPHER *cipher; + +#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L + const unsigned char *proto; + unsigned int len; +#endif +#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L + const COMP_METHOD *comp; +#endif + + 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); + } + + objPtr = Tcl_NewListObj(0, NULL); + + /* Get connection state */ + statePtr = (State *)Tcl_GetChannelInstanceData(chan); + ssl = statePtr->ssl; + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("state", -1)); + if (SSL_is_init_finished(ssl)) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("established", -1)); + } else if (SSL_in_init(ssl)) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("handshake", -1)); + } else { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("initializing", -1)); + } + + /* Get server name */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("server", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_servername(ssl, TLSEXT_NAMETYPE_host_name), -1)); + + /* Get protocol */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("protocol", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_get_version(ssl), -1)); + + /* Get cipher */ + cipher = SSL_get_current_cipher(ssl); + if (cipher != NULL) { + char buf[BUFSIZ] = {0}; + int bits, alg_bits; + + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("cipher", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_name(cipher), -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("standard_name", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_standard_name(cipher), -1)); + + bits = SSL_CIPHER_get_bits(cipher, &alg_bits); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("bits", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(bits)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("secret_bits", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(alg_bits)); + /* alg_bits is actual key secret bits. If use bits and secret (algorithm) bits differ, + the rest of the bits are fixed, i.e. for limited export ciphers (bits < 56) */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("min_version", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_CIPHER_get_version(cipher), -1)); + + if (SSL_CIPHER_description(cipher, buf, sizeof(buf)) != NULL) { + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("description", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(buf, -1)); + } + } + + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("renegotiation", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj( + SSL_get_secure_renegotiation_support(ssl) ? "allowed" : "disallowed", -1)); + +#if !defined(OPENSSL_NO_TLSEXT) && OPENSSL_VERSION_NUMBER >= 0x10002000L + /* Report the selected protocol as a result of the negotiation */ + SSL_get0_alpn_selected(ssl, &proto, &len); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("alpn", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj((char *)proto, (int)len)); +#endif + + /* Session info */ + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("session_reused", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewIntObj(SSL_session_reused(ssl))); + +#if defined(HAVE_SSL_COMPRESSION) && OPENSSL_VERSION_NUMBER >= 0x10002000L + /* Compression info */ + comp = SSL_get_current_compression(ssl); + if (comp != NULL) { + expansion = SSL_get_current_expansion(ssl); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("compression", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(comp), -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj("expansion", -1)); + Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(SSL_COMP_get_name(expansion), -1)); + } +#endif + + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; + clientData = clientData; +} + +/* + *------------------------------------------------------------------- + * * VersionObjCmd -- return version string from OpenSSL. * * Results: * A standard Tcl result. * @@ -1845,16 +2046,18 @@ 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::connection", ConnectionInfoObjCmd, (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); + Tcl_CreateObjCommand(interp, "tls::protocols", ProtocolsObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); if (interp) { Tcl_Eval(interp, tlsTclInitScript); } ADDED tests/README.txt Index: tests/README.txt ================================================================== --- /dev/null +++ tests/README.txt @@ -0,0 +1,17 @@ +Create Test Cases + +1. Create test case *.csv file. You can use multiple files. Generally it's a good idea to group like functions in the same file. + +2. Add test cases to *.csv files. + Each test case is on a separate line. Each column defines the equivalent input the tcltest tool expects. + +3. Define any common functions in common.tcl or in *.csv file. + +4. To create the test cases script, execute make_test_files.tcl. This will use the *.csv files to create the *.test files. + +Execute Test Suite + +5. To run the test suite, execute the all.tcl file. The results will be output to the stdoutlog.txt file. + On Windows you can also use the run_all_tests.bat file. + +6. Review stdoutlog.txt for the count of test cases executed successfully and view details of those that failed. Index: tests/all.tcl ================================================================== --- tests/all.tcl +++ tests/all.tcl @@ -7,53 +7,47 @@ # 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 path [file normalize [file dirname [file join [pwd] [info script]]]] #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]]] +set auto_path [linsert $auto_path 0 [file dirname $path] [file normalize [pwd]]] if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } + +# Get common functions +if {[file exists [file join $path common.tcl]]} { + source [file join $path common.tcl] +} set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] # We should ensure that the testsDirectory is absolute. # This was introduced in Tcl 8.3+'s tcltest, so we need a catch. catch {::tcltest::normalizePath ::tcltest::testsDirectory} -puts stdout "Tests running in interp: [info nameofexecutable]" -puts stdout "Tests running in working dir: $::tcltest::testsDirectory" -if {[llength $::tcltest::skip] > 0} { - puts stdout "Skipping tests that match: $::tcltest::skip" -} -if {[llength $::tcltest::match] > 0} { - puts stdout "Only running tests that match: $::tcltest::match" -} - -if {[llength $::tcltest::skipFiles] > 0} { - puts stdout "Skipping test files that match: $::tcltest::skipFiles" -} -if {[llength $::tcltest::matchFiles] > 0} { - puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" -} - -set timeCmd {clock format [clock seconds]} -puts stdout "Tests began at [eval $timeCmd]" - -# source each of the specified tests -foreach file [lsort [::tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts stdout $tail - if {[catch {source $file} msg]} { - puts stdout $msg - } -} - -# cleanup -puts stdout "\nTests ended at [eval $timeCmd]" -::tcltest::cleanupTests 1 -return - +# +# Run all tests in current and any sub directories with an all.tcl file. +# +set exitCode 0 +if {[package vsatisfies [package require tcltest] 2.5-]} { + if {[::tcltest::runAllTests] == 1} { + set exitCode 1 + } + +} else { + # Hook to determine if any of the tests failed. Then we can exit with the + # proper exit code: 0=all passed, 1=one or more failed + proc tcltest::cleanupTestsHook {} { + variable numTests + set exitCode [expr {$numTests(Total) == 0 || $numTests(Failed) > 0}] + } + ::tcltest::runAllTests +} + +# Exit code: 0=all passed, 1=one or more failed +exit $exitCode ADDED tests/ciphers.csv Index: tests/ciphers.csv ================================================================== --- /dev/null +++ tests/ciphers.csv @@ -0,0 +1,46 @@ +# Group,Name,Constraints,Setup,Body,Cleanup,Match,Result,Output,Error Output,Return Codes +command,package require tls,,,,,,,,, +command,,,,,,,,,, +command,# Make sure path includes location of OpenSSL executable,,,,,,,,, +command,"if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] "";"" $::env(path)}",,,,,,,,, +command,,,,,,,,,, +command,# Constraints,,,,,,,,, +command,set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3],,,,,,,,, +command,foreach protocol $protocols {::tcltest::testConstraint $protocol 0},,,,,,,,, +command,foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1},,,,,,,,, +command,"::tcltest::testConstraint OpenSSL [string match ""OpenSSL*"" [::tls::version]]",,,,,,,,, +,,,,,,,,,, +command,# Helper functions,,,,,,,,, +command,"proc lcompare {list1 list2} {set m """";set u """";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list ""missing"" $m ""unexpected"" $u]}",,,,,,,,, +command,proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]},,,,,,,,, +,,,,,,,,,, +command,# Test protocols,,,,,,,,, +Protocols,All,,,lcompare $protocols [::tls::protocols],,,missing {ssl2 ssl3} unexpected {},,, +,,,,,,,,,, +command,# Test ciphers,,,,,,,,, +CiphersAll,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2] [::tls::ciphers ssl2]",,,missing {} unexpected {},,, +CiphersAll,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3] [::tls::ciphers ssl3]",,,missing {} unexpected {},,, +CiphersAll,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1] [::tls::ciphers tls1]",,,missing {} unexpected {},,, +CiphersAll,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1] [::tls::ciphers tls1.1]",,,missing {} unexpected {},,, +CiphersAll,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2] [::tls::ciphers tls1.2]",,,missing {} unexpected {},,, +CiphersAll,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3] [::tls::ciphers tls1.3]",,,missing {} unexpected {},,, +,,,,,,,,,, +command,# Test cipher descriptions,,,,,,,,, +CiphersDesc,SSL2,ssl2,,"lcompare [exec_get ""\r\n"" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n]",,,missing {} unexpected {},,, +CiphersDesc,SSL3,ssl3,,"lcompare [exec_get ""\r\n"" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n]",,,missing {} unexpected {},,, +CiphersDesc,TLS1,tls1,,"lcompare [exec_get ""\r\n"" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n]",,,missing {} unexpected {},,, +CiphersDesc,TLS1.1,tls1.1,,"lcompare [exec_get ""\r\n"" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n]",,,missing {} unexpected {},,, +CiphersDesc,TLS1.2,tls1.2,,"lcompare [exec_get ""\r\n"" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n]",,,missing {} unexpected {},,, +CiphersDesc,TLS1.3,tls1.3,,"lcompare [exec_get ""\r\n"" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n]",,,missing {} unexpected {},,, +,,,,,,,,,, +command,# Test protocol specific ciphers,,,,,,,,, +CiphersSpecific,SSL2,ssl2,,"lcompare [exec_get "":"" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1]",,,missing {} unexpected {},,, +CiphersSpecific,SSL3,ssl3,,"lcompare [exec_get "":"" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1]",,,missing {} unexpected {},,, +CiphersSpecific,TLS1,tls1,,"lcompare [exec_get "":"" ciphers -tls1 -s] [::tls::ciphers tls1 0 1]",,,missing {} unexpected {},,, +CiphersSpecific,TLS1.1,tls1.1,,"lcompare [exec_get "":"" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1]",,,missing {} unexpected {},,, +CiphersSpecific,TLS1.2,tls1.2,,"lcompare [exec_get "":"" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1]",,,missing {} unexpected {},,, +CiphersSpecific,TLS1.3,tls1.3,,"lcompare [exec_get "":"" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1]",,,missing {} unexpected {},,, +,,,,,,,,,, +command,# Test version,,,,,,,,, +Version,All,,,::tls::version,,glob,*,,, +Version,OpenSSL,OpenSSL,,::tls::version,,glob,OpenSSL*,,, Index: tests/ciphers.test ================================================================== --- tests/ciphers.test +++ tests/ciphers.test @@ -1,157 +1,121 @@ -# Commands covered: tls::ciphers -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# - -# All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} - -# The build dir is added as the first element of $PATH +# Auto generated test cases for ciphers_and_protocols.csv + +# Load Tcl Test package +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import ::tcltest::* +} + +set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path] + package require tls -# One of these should == 1, depending on what type of ssl library -# tls was compiled against. (RSA BSAFE SSL-C or OpenSSL). -# -set ::tcltest::testConstraints(rsabsafe) 0 -set ::tcltest::testConstraints(openssl) [string match "OpenSSL*" [tls::version]] - -set ::EXPECTEDCIPHERS(rsabsafe) { - EDH-DSS-RC4-SHA - EDH-RSA-DES-CBC3-SHA - EDH-DSS-DES-CBC3-SHA - DES-CBC3-SHA - RC4-SHA - RC4-MD5 - EDH-RSA-DES-CBC-SHA - EDH-DSS-DES-CBC-SHA - DES-CBC-SHA - EXP-EDH-DSS-DES-56-SHA - EXP-EDH-DSS-RC4-56-SHA - EXP-DES-56-SHA - EXP-RC4-56-SHA - EXP-EDH-RSA-DES-CBC-SHA - EXP-EDH-DSS-DES-CBC-SHA - EXP-DES-CBC-SHA - EXP-RC2-CBC-MD5 - EXP-RC4-MD5 -} - -set ::EXPECTEDCIPHERS(openssl) { - AES128-SHA - AES256-SHA - DES-CBC-SHA - DES-CBC3-SHA - DHE-DSS-AES128-SHA - DHE-DSS-AES256-SHA - DHE-DSS-RC4-SHA - DHE-RSA-AES128-SHA - DHE-RSA-AES256-SHA - EDH-DSS-DES-CBC-SHA - EDH-DSS-DES-CBC3-SHA - EDH-RSA-DES-CBC-SHA - EDH-RSA-DES-CBC3-SHA - EXP-DES-CBC-SHA - EXP-EDH-DSS-DES-CBC-SHA - EXP-EDH-RSA-DES-CBC-SHA - EXP-RC2-CBC-MD5 - EXP-RC4-MD5 - EXP1024-DES-CBC-SHA - EXP1024-DHE-DSS-DES-CBC-SHA - EXP1024-DHE-DSS-RC4-SHA - EXP1024-RC2-CBC-MD5 - EXP1024-RC4-MD5 - EXP1024-RC4-SHA - IDEA-CBC-SHA - RC4-MD5 - RC4-SHA -} - -set ::EXPECTEDCIPHERS(openssl0.9.8) { - DHE-RSA-AES256-SHA - DHE-DSS-AES256-SHA - AES256-SHA - EDH-RSA-DES-CBC3-SHA - EDH-DSS-DES-CBC3-SHA - DES-CBC3-SHA - DHE-RSA-AES128-SHA - DHE-DSS-AES128-SHA - AES128-SHA - IDEA-CBC-SHA - RC4-SHA - RC4-MD5 - EDH-RSA-DES-CBC-SHA - EDH-DSS-DES-CBC-SHA - DES-CBC-SHA - EXP-EDH-RSA-DES-CBC-SHA - EXP-EDH-DSS-DES-CBC-SHA - EXP-DES-CBC-SHA - EXP-RC2-CBC-MD5 - EXP-RC4-MD5 -} - -set version "" -if {[string match "OpenSSL*" [tls::version]]} { - regexp {OpenSSL ([\d\.]+)} [tls::version] -> version -} -if {![info exists ::EXPECTEDCIPHERS(openssl$version)]} { - set version "" -} - -proc listcompare {wants haves} { - array set want {} - array set have {} - foreach item $wants { set want($item) 1 } - foreach item $haves { set have($item) 1 } - foreach item [lsort -dictionary [array names have]] { - if {[info exists want($item)]} { - unset want($item) have($item) - } - } - if {[array size want] || [array size have]} { - return [list MISSING [array names want] UNEXPECTED [array names have]] - } -} - -test ciphers-1.1 {Tls::ciphers for ssl3} {rsabsafe} { - # This will fail if you compiled against OpenSSL. - # Change the constraint setting above. - listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers ssl3] -} {} - -test ciphers-1.2 {Tls::ciphers for tls1} {rsabsafe} { - # This will fail if you compiled against OpenSSL. - # Change the constraint setting above. - listcompare $::EXPECTEDCIPHERS(rsabsafe) [tls::ciphers tls1] -} {} - -test ciphers-1.3 {Tls::ciphers for ssl3} {openssl} { - # This will fail if you compiled against RSA bsafe or with a - # different set of defines than the default. - # Change the constraint setting above. - listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers ssl3] -} {} - -# This version of the test is correct for OpenSSL only. -# An equivalent test for the RSA BSAFE SSL-C is earlier in this file. - -test ciphers-1.4 {Tls::ciphers for tls1} {openssl} { - # This will fail if you compiled against RSA bsafe or with a - # different set of defines than the default. - # Change the constraint setting in all.tcl - listcompare $::EXPECTEDCIPHERS(openssl$version) [tls::ciphers tls1] -} {} - - -# cleanup +# Make sure path includes location of OpenSSL executable +if {[info exists ::env(OPENSSL)]} {set ::env(path) [string cat [file join $::env(OPENSSL) bin] ";" $::env(path)} + +# Constraints +set protocols [list ssl2 ssl3 tls1 tls1.1 tls1.2 tls1.3] +foreach protocol $protocols {::tcltest::testConstraint $protocol 0} +foreach protocol [::tls::protocols] {::tcltest::testConstraint $protocol 1} +::tcltest::testConstraint OpenSSL [string match "OpenSSL*" [::tls::version]] +# Helper functions +proc lcompare {list1 list2} {set m "";set u "";foreach i $list1 {if {$i ni $list2} {lappend m $i}};foreach i $list2 {if {$i ni $list1} {lappend u $i}};return [list "missing" $m "unexpected" $u]} +proc exec_get {delim args} {return [split [exec openssl {*}$args] $delim]} +# Test protocols + + +test Protocols-1.1 {All} -body { + lcompare $protocols [::tls::protocols] + } -result {missing {ssl2 ssl3} unexpected {}} +# Test ciphers + + +test CiphersAll-2.1 {SSL2} -constraints {ssl2} -body { + lcompare [exec_get ":" ciphers -ssl2] [::tls::ciphers ssl2] + } -result {missing {} unexpected {}} + +test CiphersAll-2.2 {SSL3} -constraints {ssl3} -body { + lcompare [exec_get ":" ciphers -ssl3] [::tls::ciphers ssl3] + } -result {missing {} unexpected {}} + +test CiphersAll-2.3 {TLS1} -constraints {tls1} -body { + lcompare [exec_get ":" ciphers -tls1] [::tls::ciphers tls1] + } -result {missing {} unexpected {}} + +test CiphersAll-2.4 {TLS1.1} -constraints {tls1.1} -body { + lcompare [exec_get ":" ciphers -tls1_1] [::tls::ciphers tls1.1] + } -result {missing {} unexpected {}} + +test CiphersAll-2.5 {TLS1.2} -constraints {tls1.2} -body { + lcompare [exec_get ":" ciphers -tls1_2] [::tls::ciphers tls1.2] + } -result {missing {} unexpected {}} + +test CiphersAll-2.6 {TLS1.3} -constraints {tls1.3} -body { + lcompare [exec_get ":" ciphers -tls1_3] [::tls::ciphers tls1.3] + } -result {missing {} unexpected {}} +# Test cipher descriptions + + +test CiphersDesc-3.1 {SSL2} -constraints {ssl2} -body { + lcompare [exec_get "\r\n" ciphers -ssl2 -v] [split [string trim [::tls::ciphers ssl2 1]] \n] + } -result {missing {} unexpected {}} + +test CiphersDesc-3.2 {SSL3} -constraints {ssl3} -body { + lcompare [exec_get "\r\n" ciphers -ssl3 -v] [split [string trim [::tls::ciphers ssl3 1]] \n] + } -result {missing {} unexpected {}} + +test CiphersDesc-3.3 {TLS1} -constraints {tls1} -body { + lcompare [exec_get "\r\n" ciphers -tls1 -v] [split [string trim [::tls::ciphers tls1 1]] \n] + } -result {missing {} unexpected {}} + +test CiphersDesc-3.4 {TLS1.1} -constraints {tls1.1} -body { + lcompare [exec_get "\r\n" ciphers -tls1_1 -v] [split [string trim [::tls::ciphers tls1.1 1]] \n] + } -result {missing {} unexpected {}} + +test CiphersDesc-3.5 {TLS1.2} -constraints {tls1.2} -body { + lcompare [exec_get "\r\n" ciphers -tls1_2 -v] [split [string trim [::tls::ciphers tls1.2 1]] \n] + } -result {missing {} unexpected {}} + +test CiphersDesc-3.6 {TLS1.3} -constraints {tls1.3} -body { + lcompare [exec_get "\r\n" ciphers -tls1_3 -v] [split [string trim [::tls::ciphers tls1.3 1]] \n] + } -result {missing {} unexpected {}} +# Test protocol specific ciphers + + +test CiphersSpecific-4.1 {SSL2} -constraints {ssl2} -body { + lcompare [exec_get ":" ciphers -ssl2 -s] [::tls::ciphers ssl2 0 1] + } -result {missing {} unexpected {}} + +test CiphersSpecific-4.2 {SSL3} -constraints {ssl3} -body { + lcompare [exec_get ":" ciphers -ssl3 -s] [::tls::ciphers ssl3 0 1] + } -result {missing {} unexpected {}} + +test CiphersSpecific-4.3 {TLS1} -constraints {tls1} -body { + lcompare [exec_get ":" ciphers -tls1 -s] [::tls::ciphers tls1 0 1] + } -result {missing {} unexpected {}} + +test CiphersSpecific-4.4 {TLS1.1} -constraints {tls1.1} -body { + lcompare [exec_get ":" ciphers -tls1_1 -s] [::tls::ciphers tls1.1 0 1] + } -result {missing {} unexpected {}} + +test CiphersSpecific-4.5 {TLS1.2} -constraints {tls1.2} -body { + lcompare [exec_get ":" ciphers -tls1_2 -s] [::tls::ciphers tls1.2 0 1] + } -result {missing {} unexpected {}} + +test CiphersSpecific-4.6 {TLS1.3} -constraints {tls1.3} -body { + lcompare [exec_get ":" ciphers -tls1_3 -s] [::tls::ciphers tls1.3 0 1] + } -result {missing {} unexpected {}} +# Test version + + +test Version-5.1 {All} -body { + ::tls::version + } -match {glob} -result {*} + +test Version-5.2 {OpenSSL} -constraints {OpenSSL} -body { + ::tls::version + } -match {glob} -result {OpenSSL*} + +# Cleanup ::tcltest::cleanupTests return ADDED tests/make_test_files.tcl Index: tests/make_test_files.tcl ================================================================== --- /dev/null +++ tests/make_test_files.tcl @@ -0,0 +1,123 @@ +# +# Name: Make Test Files From CSV Files +# Version: 0.2 +# Date: August 6, 2022 +# Author: Brian O'Hagan +# Email: brian199@comcast.net +# Legal Notice: (c) Copyright 2020 by Brian O'Hagan +# Released under the Apache v2.0 license. I would appreciate a copy of any modifications +# made to this package for possible incorporation in a future release. +# + +# +# Convert test case file into test files +# +proc process_config_file {filename} { + set prev "" + set test 0 + + # Open file with test case indo + set in [open $filename r] + array set cases [list] + + # Open output test file + set out [open [format %s.test [file rootname $filename]] w] + array set cases [list] + + # Add setup commands to test file + puts $out [format "# Auto generated test cases for %s" [file tail $filename]] + #puts $out [format "# Auto generated test cases for %s created on %s" [file tail $filename] [clock format [clock seconds]]] + + # Package requires + puts $out "\n# Load Tcl Test package" + puts $out [subst -nocommands {if {[lsearch [namespace children] ::tcltest] == -1} {\n\tpackage require tcltest\n\tnamespace import ::tcltest::*\n}\n}] + puts $out {set auto_path [concat [list [file dirname [file dirname [info script]]]] $auto_path]} + puts $out "" + + # Generate test cases and add to test file + while {[gets $in data] > -1} { + # Skip comments + set data [string trim $data] + if {[string match "#*" $data]} continue + + # Split comma separated fields with quotes + set list [list] + while {[string length $data] > 0} { + if {[string index $data 0] eq "\""} { + # Quoted + set end [string first "\"," $data] + if {$end == -1} {set end [expr {[string length $data]+1}]} + lappend list [string map [list {""} \"] [string range $data 1 [incr end -1]]] + set data [string range $data [incr end 3] end] + + } else { + # Not quoted, so no embedded NL, quotes, or commas + set index [string first "," $data] + if {$index == -1} {set index [expr {[string length $data]+1}]} + lappend list [string range $data 0 [incr index -1]] + set data [string range $data [incr index 2] end] + } + } + + # Get command or test case + foreach {group name constraints setup body cleanup match result output errorOutput returnCodes} $list { + if {$group eq "command"} { + # Pass-through command + puts $out $name + + } elseif {$group ne "" && $body ne ""} { + set group [string map [list " " "_"] $group] + if {$group ne $prev} { + incr test + set prev $group + puts $out "" + } + + # Test case + set buffer [format "\ntest %s-%d.%d {%s}" $group $test [incr cases($group)] $name] + foreach opt [list -constraints -setup -body -cleanup -match -result -output -errorOutput -returnCodes] { + set cmd [string trim [set [string trimleft $opt "-"]]] + if {$cmd ne ""} { + if {$opt in [list -setup -body -cleanup]} { + append buffer " " $opt " \{\n" + foreach line [split $cmd ";"] { + append buffer \t [string trim $line] \n + } + append buffer " \}" + } elseif {$opt in [list -output -errorOutput]} { + append buffer " " $opt " {" $cmd \n "}" + } elseif {$opt in [list -result]} { + if {[string index $cmd 0] in [list \[ \" \{]} { + append buffer " " $opt " " $cmd + } elseif {[string match {*[\\$]*} $cmd]} { + append buffer " " $opt " \"" [string map [list \\\\\" \\\"] [string map [list \" \\\" ] $cmd]] "\"" + } else { + append buffer " " $opt " {" $cmd "}" + } + } else { + append buffer " " $opt " {" $cmd "}" + } + } + } + puts $out $buffer + + } else { + # Empty line + } + break + } + } + + # Output clean-up commands + puts $out "\n# Cleanup\n::tcltest::cleanupTests\nreturn" + close $out + close $in +} + +# +# Call script +# +foreach file [glob *.csv] { + process_config_file $file +} +exit