diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/devtools | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/devtools')
-rw-r--r-- | tcllib/modules/devtools/ChangeLog | 245 | ||||
-rw-r--r-- | tcllib/modules/devtools/README | 22 | ||||
-rw-r--r-- | tcllib/modules/devtools/ca.crt | 17 | ||||
-rw-r--r-- | tcllib/modules/devtools/ca.key | 18 | ||||
-rw-r--r-- | tcllib/modules/devtools/ca.key.password | 1 | ||||
-rw-r--r-- | tcllib/modules/devtools/coserv.tcl | 128 | ||||
-rw-r--r-- | tcllib/modules/devtools/dialog.tcl | 346 | ||||
-rw-r--r-- | tcllib/modules/devtools/receiver.crt | 18 | ||||
-rw-r--r-- | tcllib/modules/devtools/receiver.key | 15 | ||||
-rw-r--r-- | tcllib/modules/devtools/testutilities.tcl | 722 | ||||
-rw-r--r-- | tcllib/modules/devtools/transmitter.crt | 18 | ||||
-rw-r--r-- | tcllib/modules/devtools/transmitter.key | 15 |
12 files changed, 1565 insertions, 0 deletions
diff --git a/tcllib/modules/devtools/ChangeLog b/tcllib/modules/devtools/ChangeLog new file mode 100644 index 0000000..baff9a8 --- /dev/null +++ b/tcllib/modules/devtools/ChangeLog @@ -0,0 +1,245 @@ +2013-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * transmitter.crt: [Bug 3433470] Regenerated the certificates, + * transmitter.key: again. Expiry is Jan 2023 (10 years). + * receiver.crt: While SimpleCA doesn't seem to allow me to + * receiver.key: specify a longer period in the GUI it was possible + * ca.crt: to get, update and run the Tcl code, unwrapped. + * ca.key: Further changed to 4096-bit certs. + +2011-11-09 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Fixed typos, one still breaking 'testsNeed'. + +2011-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Fixed 'testsNeed' command to require the + needed package and abort properly when it is not found. + + * transmitter.crt: [Bug 3433470] Regenerated the certificates. + * transmitter.key: Expiry is Nov 2012. SimpleCA doesn't seem + * receiver.crt: to allow me to specify a longer period. :( + * receiver.key: Updated README. + * ca.crt: + * ca.key: + * README: + +2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added new constraint to identify core version + upto Tcl 8.5, but not higher. + +2011-01-20 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl (useTcllibC): Account for the possibility of + the environment providing a tcllibc, instead of a Tcllib local + one. + +2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl (snitTooManyArgs): Fixed error messages for + snit 1.x series. + +2010-09-15 Andreas Kupries <andreask@activestate.com> + + * testutilities.tcl: [Bug 3066026]: Moved the tcltest + compatibility initialization into a procedure (InitializeTcltest) + which is called by testNeedsTcltest and a few other places to be + done only after we are sure that the tcltest package is present. + +2010-03-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added constraint for 8.4-. + +2009-09-24 Andreas Kupries <andreask@activestate.com> + + * testutilities.tcl: Added constraint for 8.6+. + +2009-04-13 Andreas Kupries <andreask@activestate.com> + + * dialog.tcl: Extended to allow dialog over a socket secured by + SSL (via package tls). + +2009-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * ca.crt: New files, SSL/TLS certificates for use in testsuites. + * ca.key: ca.* = Tcllib Certification Authority + * ca.key.password: Receiver, Transmitter = Certificates for two + * receiver.crt: sides of a communication channel. + * receiver.key: + * transmitter.crt: + * transmitter.key: + + * README: Acknowledgement added for the SimpleCA software used to + create the certificates. + +2008-09-20 Michael Schlenker <mic42@users.sourceforge.net> + + * testutitlites.tcl: Added wrong num args error messages for + Tcl 8.6 alphas, to make tests pass. + +2007-04-30 Andreas Kupries <andreask@activestate.com> + + * testutilities.tcl: Made TestFiles 8.2-ready. Added command + 'TestFilesGlob' to simply return files instead of immediately + sourcing them. + +2007-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added 'TestFiles', a command to run a set of + subordinate test files, found by globbing. + + * testutilities.tcl: Added 'useAccel' to help with the setup of + packages which have accelerators, automatically using the proper + use variant. + +2006-10-11 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Extended with three commands to make testing + of packages with multiple implementations (accelerators) + easier. A specific API for querying and manipulating + accelerators is assumed. + +2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Changed variable definitions to shield + against creative writing. Added common code to save and restore + the environment (::env), for testsuites which have to (1) either + modify it as part of the tests, or (2) shield themselves against + manipulation from the environment. + +2006-09-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dialog.tcl: Bugfix in 'Input', cleaning up the waiting timer + when reaching eof on the socket. Could otherwise trigger + while executing an unrelated future dialog. Extended to manage + two traces, the new one a condensed form of the existing trace, + easier to put into the result of a testcase. + + * coserv.tcl: Reworked a bit to allow the restart of a server + after a shutdown, by recreating the helper file executed by the + slave-process. + +2006-09-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Modified use commands to ensure that their + output is a proper list. + +2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added commands constructing wrong#args + messages for snit methods, depending on snit version. + +2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Ensure that the makeFile/Dir wrapper are + created only once. Also modified the code to modify the + originals to return the full name. The wrapper are needed only + as indicators. + +2006-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added set of commands for the easy assembly + of complex results. Mainly a shorthand for 'lappend', using a + common variable. + +2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Force re-import of tcltest commands after + changes made by the support system. Added code forcing a useful + result value of makeFile/makeDirectory even for Tcltest 1.x + (path created instead of list of all paths). Command for the + creation of a binary temp. file, and a command to return the + path of temp files without us having to create them. + + * coserv.tcl: Fixed usage of temp. files by comm server. + + * coserv.tcl: Fixed output for a better fit with the other test + * dialog.tcl: support. + +2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added variants of the use commands which keep + the relevant namespace. Sometimes necessary to prevent + destruction of support code loaded first. + +2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Added commands for the loading of files and + packages from the Tcllib under test. This will reduce the amount + of boilerplate in a .test file spent on getting the package + under test, its supporting packages, and other helper files. + + Added helpers for dealing with loading "tcllibc" package and + packages using it. + +2006-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: Moved the definitions of the common + constraints out of the toplevel "all.tcl" into the test support + code. + +2006-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * testutilities.tcl: New file for boilerplate code and common + commands used by most to all testsuites in Tcllib. + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2004-10-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * dialog.tcl: More log output for better tracing of the + internals. Especially added trace when receiving an incomplete + line while waiting for data from the peer. Added code to clean + up old connections, prevent leakage of channel handles. + +2004-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * muserv.tcl: Removed the old facilities for sub processes + * musub.tcl: and programmed interactions. They have been + * subserv.tcl: superceded by the code below. + + * coserv.tcl: New sub process mgmt based on "comm". + * dialog.tcl: New code for programmed dialogs based on + "coserv.tcl". + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-05-01 Andreas Kupries <andreask@activestate.com> + + * subserv.tcl (muserv): Propagate the auto_path into the + subprocess so that it is able to find all packages the server + might require. Without that the server will need an installed + tcllib, for example. This fixes a hang in the pop3 testsuite + when tcllib is not installed. + +2003-04-09 Andreas Kupries <andreask@activestate.com> + + * New module. + * First contents are support for sub-processes in testsuites. diff --git a/tcllib/modules/devtools/README b/tcllib/modules/devtools/README new file mode 100644 index 0000000..ba9857f --- /dev/null +++ b/tcllib/modules/devtools/README @@ -0,0 +1,22 @@ + +Right now this module only contains code to make the handling of sub +processes from within a testsuite easier in general and of minimal +protocol server especially. Things which are not directly within in +the scope of the package "tcltest". + +The initial name for the module was 'testsupport'. This was changed to +'devtools' to allow the collection other code here too. Like for +example the generation of TEA 2 compatible configure scripts and +Makefiles. + +For now the contents are considered internal to tcllib and are neither +listed in the main makefile, nor do they have a package index file. So +even if the module and its code gets installed it won't be useable +without jumping through some hoops. + +The code is used in some of the tcllib testsuites. +Currently: "comm", and "pop3". + +These certificates have been created with SimpleCA, +see http://wiki.tcl.tk/11419 +and http://users.skynet.be/ballet/joris/SimpleCA/ diff --git a/tcllib/modules/devtools/ca.crt b/tcllib/modules/devtools/ca.crt new file mode 100644 index 0000000..28a3705 --- /dev/null +++ b/tcllib/modules/devtools/ca.crt @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICtDCCAh2gAwIBAgIJAKWjOP4GKWjhMA0GCSqGSIb3DQEBBAUAMIGBMQswCQYD +VQQGEwJDQTELMAkGA1UECBMCQkMxEjAQBgNVBAcTCVZhbmNvdXZlcjEMMAoGA1UE +ChMDVENBMQ8wDQYDVQQLEwZUY2xsaWIxFzAVBgNVBAMTDlRjbGxpYiBSb290IENB +MRkwFwYJKoZIhvcNAQkBFgp0Y2xsaWJAdGNhMB4XDTEzMDEyMTIxNDUyOFoXDTIz +MDEyOTIxNDUyOFowgYExCzAJBgNVBAYTAkNBMQswCQYDVQQIEwJCQzESMBAGA1UE +BxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0ExDzANBgNVBAsTBlRjbGxpYjEXMBUG +A1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkqhkiG9w0BCQEWCnRjbGxpYkB0Y2Ew +gZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALda0hrGvGLuaLICFkkwiz0AvDqK +fFsc1nNw4A9FcQ8cpA2SMeoKLyBLANLxrn99eboSCvW+XADZ8u7uwPU2/rnLmqaZ +mGZXA2jCKMVK6yxvbXvw2oYQGUN3xYhSQtEaYOoGrjn1HpkMpDJmx4TCCwMpwZmh +I95MCZtwvnSEGJQvAgMBAAGjMjAwMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYE +FCHaYPrHbeAAAjyHQIo1129sS+ElMA0GCSqGSIb3DQEBBAUAA4GBAEMba535SbVo +wZRim/hZbH97WoWNvGA+GuEyiVvae4TQaOpFVAOxwU/l0K6qXumIs8XTCdUh9T6P +T3TOxzVL7wHRQf8QR7buZEGooss/3Nw9lZmSJbfuxg2z0qG8r6FqhnDmNK0yimBt +VmuLWF+l8gb0lBYCEZdP0AMGT6UdE5J8 +-----END CERTIFICATE----- diff --git a/tcllib/modules/devtools/ca.key b/tcllib/modules/devtools/ca.key new file mode 100644 index 0000000..99b1460 --- /dev/null +++ b/tcllib/modules/devtools/ca.key @@ -0,0 +1,18 @@ +-----BEGIN RSA PRIVATE KEY----- +Proc-Type: 4,ENCRYPTED +DEK-Info: DES-EDE3-CBC,DD33F28636691816 + +3NQhYUEuaz6bTuf3NsjybmwqfTFPdlBsX2FAn/p7lCQdbAOtSjQbcs1aC2eohfb6 +s9o7GRMMJXOH8tMr5BueSl4fBoXalsumDU0WVt/gg2vfC4js+vbgxjV6/lqhrvE2 +E442GQIQUlcO9Zs7nGATuBGWxhgW9zCZys+lTYlU33751fGIaTlIECwuxWJ/rLdJ +73MeRNH1Qi9pcPCuRmK/oOZsH0jAlMiLLrAzLx/VOB5e8cip14rjGyxh8M3a//Fv +GIO4fUD6++1FQJLl39dNNVAjCsaVCyT/R82fBrhYD/JZrh/rLGD96UyIwr9AE/PW +XySZ2YoUvwImQGdQxLSnE0x+MtxPwt5iNXr586jB2Wz1G8fjYPNDz4tUkM/8iUVi +I/Pn8JyErul9AVZqQkSCoytrmqajMO9xZAym+R8qgvqkQuSZL2MwPgNZRJ5H01kC +Z1xRw2jNobSOPyBEG03TOBpXHKayzpIdqEx7ZUuG2FLa1uTicmVnwyuE6jQCgMo3 +wTNrLCzeNJgNggk4XaSzMqy1zAltBx/Q3aPbrspKt1JvAboFu/+TJBwfi/Gk+MT1 +RBWUB6d/4YsnW+6mx/68TlL9TVDnvSzkW8/EW/JrCL5mAJYjN4c5/0++Qu/8g6d/ +icy7g4gz0JaEN7s0jh6lPWlYC+2cj9d3vB3uY2j+9KsUqOalr4jhSZ8sidh7T3OA +iuQGIgrnZQgU6tZa0MeTct/zxBup4r1sfpyuYYWatkD0QTejH4rzKASWAQD81mOs +0wzxdS10/kCjzXrh/5EDq5B1wiD506/PpRXej/l8oxHqhNE338YlSQ== +-----END RSA PRIVATE KEY----- diff --git a/tcllib/modules/devtools/ca.key.password b/tcllib/modules/devtools/ca.key.password new file mode 100644 index 0000000..faddeb7 --- /dev/null +++ b/tcllib/modules/devtools/ca.key.password @@ -0,0 +1 @@ +tcllib-devel diff --git a/tcllib/modules/devtools/coserv.tcl b/tcllib/modules/devtools/coserv.tcl new file mode 100644 index 0000000..2b051e4 --- /dev/null +++ b/tcllib/modules/devtools/coserv.tcl @@ -0,0 +1,128 @@ +# -*- tcl -*- +# CoServ - Comm Server +# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net> + +# ### ### ### ######### ######### ######### +## Commands to create server processes ready to talk to their parent +## via 'comm'. They assume that the 'tcltest' environment is present +## without having to load it explicitly. We do load 'comm' explicitly. + +## Can assume that tcltest is present, and its commands imported into +## the global namespace. + +# ### ### ### ######### ######### ######### +## Load "comm" into the master. + +namespace eval ::coserv {variable subcode {}} + +package forget comm +catch {namespace delete comm} + +if {[package vsatisfies [package present Tcl] 8.5]} { + set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit2.tcl] +} else { + set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit.tcl] +} +set ::coserv::commsrc [file join [file dirname [file dirname [info script]]] comm comm.tcl] + +if {[catch {source $::coserv::snitsrc} msg]} { + puts "Error loading \"snit\": $msg" + error "" +} +if {[catch {source $::coserv::commsrc} msg]} { + puts "Error loading \"comm\": $msg" + error "" +} + +package require comm + +puts "- coserv (comm server)" +#puts "Main @ [::comm::comm self]" + +# ### ### ### ######### ######### ######### +## Core of all sub processes. + +proc ::coserv::setup {} { + variable subcode + if {$subcode != {}} return + set subcode [::tcltest::makeFile { + #puts "Subshell is \"[info nameofexecutable]\"" + catch {wm withdraw .} + + # ### ### ### ######### ######### ######### + ## Get main configuration data out of the command line, i.e. + ## - Id of the main process for sending information back. + ## - Path to the sources of comm. + + foreach {snitsrc commsrc main cookie} $argv break + + # ### ### ### ######### ######### ######### + ## Load and initialize "comm" in the sub process. The latter + ## includes a report to main that we are ready. + + source $snitsrc + source $commsrc + ::comm::comm send $main [list ::coserv::ready $cookie [::comm::comm self]] + + # ### ### ### ######### ######### ######### + ## Now wait for scripts sent by main for execution in sub. + + #comm::comm debug 1 + vwait forever + + # ### ### ### ######### ######### ######### + exit + } coserv.sub] ; # {} + return +} + +# ### ### ### ######### ######### ######### +## Command used by sub processes to signal that they are ready. + +proc ::coserv::ready {cookie id} { + #puts "Sub server @ $id\t\[$cookie\]" + set ::coserv::go $id + return +} + +# ### ### ### ######### ######### ######### +## Start a new sub server process, talk to it. + +proc ::coserv::start {cookie} { + variable subcode + variable snitsrc + variable commsrc + variable go + + set go {} + + setup + exec [info nameofexecutable] $subcode \ + $snitsrc $commsrc [::comm::comm self] $cookie & + + #puts "Waiting for sub server to boot" + vwait ::coserv::go + + # We return the id of the server + return $::coserv::go +} + +proc ::coserv::run {id script} { + return [comm::comm send $id $script] +} + +proc ::coserv::task {id script} { + comm::comm send -async $id $script + return +} + +proc ::coserv::shutdown {id} { + variable subcode + #puts "Sub server @ $id\tShutting down ..." + task $id exit + tcltest::removeFile $subcode + set subcode {} + return +} + +# ### ### ### ######### ######### ######### diff --git a/tcllib/modules/devtools/dialog.tcl b/tcllib/modules/devtools/dialog.tcl new file mode 100644 index 0000000..01fd790 --- /dev/null +++ b/tcllib/modules/devtools/dialog.tcl @@ -0,0 +1,346 @@ +# -*- tcl -*- +# Dialog - Dialog Demon (Server, or Client) +# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net> + +puts "- dialog (coserv-based)" + +# ### ### ### ######### ######### ######### +## Commands on top of a plain comm server. +## Assumes that the comm server environment +## is present. Provides set up and execution +## of a fixed linear dialog, done from the +# perspective of a server application. + +# ### ### ### ######### ######### ######### +## Load "comm" into the master. + +namespace eval ::dialog { + variable dtrace {} +} + +# ### ### ### ######### ######### ######### +## Start a new dialog server. + +proc ::dialog::setup {type cookie {ssl 0}} { + variable id + variable port + + switch -- $type { + server {set server 1} + client {set server 0} + default {return -code error "Bad dialog type \"$type\", expected server, or client"} + } + + set id [::coserv::start "$type: $cookie"] + ::coserv::run $id { + set responses {} + set strace {} + set received {} + set conn {} + set ilog {} + + proc Log {text} { + global ilog ; lappend ilog $text + } + proc Strace {text} { + global strace ; lappend strace $text + } + proc Exit {sock reason} { + Strace $reason + Log [list $reason $sock] + close $sock + Done + } + proc Done {} { + global main strace ilog + comm::comm send $main [list dialog::done [list $strace $ilog]] + return + } + proc ClearTraces {} { + global strace ; set strace {} + global ilog ; set ilog {} + return + } + proc Step {sock} { + global responses trace + + if {![llength $responses]} { + Exit $sock empty + return + } + + set now [lindex $responses 0] + set responses [lrange $responses 1 end] + + Log [list ** $sock $now] + eval [linsert $now end $sock] + return + } + + # Step commands ... + + proc .Crlf {sock} { + Strace crlf + Log crlf + fconfigure $sock -translation crlf + Step $sock + return + } + proc .Binary {sock} { + Strace bin + Log binary + fconfigure $sock -translation binary + Step $sock + return + } + proc .HaltKeep {sock} { + Log halt.keep + Done + global responses + set responses {} + # No further stepping. + # This keeps the socket open. + # Needs external reset/cleanup + return + } + proc .Send {line sock} { + Strace [list >> $line] + Log [list >> $line] + + if {[catch { + puts $sock $line + flush $sock + } msg]} { + Exit $sock broken + return + } + Step $sock + return + } + proc .Geval {script sock} { + Log geval + uplevel #0 $script + Step $sock + return + } + proc .Eval {script sock} { + Log eval + eval $script + Step $sock + return + } + proc .SendGvar {vname sock} { + upvar #0 $vname line + .Send $line $sock + return + } + proc .Receive {sock} { + set aid [after 10000 [list Timeout $sock]] + fileevent $sock readable [list Input $aid $sock] + # No "Step" here. Comes through input. + Log " Waiting \[$aid\]" + return + } + proc Input {aid sock} { + global received + if {[eof $sock]} { + # Clean the timer up + after cancel $aid + Exit $sock close + return + } + if {[gets $sock line] < 0} { + Log " **|////|**" + return + } + + Log "-- -v-" + Log " Events off \[$aid, $sock\]" + fileevent $sock readable {} + after cancel $aid + + Strace [list << $line] + Log [list << $line] + lappend received $line + + # Now we can step further + Step $sock + return + } + proc Timeout {sock} { + Exit $sock timeout + return + } + proc Accept {sock host port} { + fconfigure $sock -blocking 0 + ClearTraces + Step $sock + return + } + + proc Server {} { + global port + # Start listener for dialog + set listener [socket -server Accept 0] + set port [lindex [fconfigure $listener -sockname] 2] + # implied return of <port> + } + + proc Client {port} { + global conn + catch {close $conn} + + set conn [set sock [socket localhost $port]] + fconfigure $sock -blocking 0 + ClearTraces + Log [list Client @ $port = $sock] + Log [list Channels $port = [lsort [file channels]]] + Step $sock + return + } + } + + if {$ssl} { + # Replace various commands with tls aware variants + coserv::run $id [list set devtools [tcllibPath devtools]] + coserv::run $id { + package require tls + + tls::init \ + -keyfile $devtools/transmitter.key \ + -certfile $devtools/transmitter.crt \ + -cafile $devtools/ca.crt \ + -ssl2 1 \ + -ssl3 1 \ + -tls1 0 \ + -require 1 + + proc Server {} { + global port + # Start listener for dialog + set listener [tls::socket -server Accept 0] + set port [lindex [fconfigure $listener -sockname] 2] + # implied return of <port> + } + + proc Client {port} { + global conn + catch {close $conn} + + set conn [set sock [tls::socket localhost $port]] + fconfigure $sock -blocking 0 + ClearTraces + Log [list Client @ $port = $sock] + Log [list Channels $port = [lsort [file channels]]] + Step $sock + return + } + } + } + + if {$server} { + set port [coserv::run $id {Server}] + } +} + +proc ::dialog::runclient {port} { + variable id + variable dtrace {} + coserv::task $id [list Client $port] + return +} + +proc ::dialog::dialog_set {response_script} { + begin + uplevel 1 $response_script + end + return +} + +proc ::dialog::begin {{cookie {}}} { + variable id + ::coserv::task $id [list set responses {}] + log::log debug "+============================================ $cookie \\\\" + return +} + +proc ::dialog::cmd {command} { + variable id + ::coserv::task $id [list lappend responses $command] + return +} + +proc ::dialog::end {} { + # This implicitly waits for all preceding commands (which are async) to complete. + variable id + set responses [::coserv::run $id [list set responses]] + ::coserv::run $id {set received {}} + log::log debug |\t[join $responses \n|\t] + log::log debug +--------------------------------------------- + return +} + +proc ::dialog::crlf. {} {cmd .Crlf} +proc ::dialog::binary. {} {cmd .Binary} +proc ::dialog::send. {line} {cmd [list .Send $line]} +proc ::dialog::receive. {} {cmd .Receive} +proc ::dialog::respond. {line} {receive. ; send. $line} +proc ::dialog::request. {line} {send. $line ; receive.} +proc ::dialog::halt.keep. {} {cmd .HaltKeep} +proc ::dialog::sendgvar. {vname} {cmd [list .SendGvar $vname]} +proc ::dialog::reqgvar. {vname} {sendgvar. $vname ; receive.} +proc ::dialog::geval. {script} {cmd [list .Geval $script]} +proc ::dialog::eval. {script} {cmd [list .Eval $script]} + +proc ::dialog::done {traces} { + variable dtrace $traces + return +} + +proc ::dialog::waitdone {} { + variable dtrace + + # Loop until we have data from the dialog subprocess. + # IOW writes which do not create data are ignored. + while {![llength $dtrace]} { + vwait ::dialog::dtrace + } + + foreach {strace ilog} $dtrace break + set dtrace {} + + log::log debug +--------------------------------------------- + log::log debug |\t[join $strace \n|\t] + log::log debug +--------------------------------------------- + log::log debug /\t[join $ilog \n/\t] + log::log debug "+============================================ //" + return $strace +} + +proc ::dialog::received {} { + # Wait for all preceding commands to complete. + variable id + set received [::coserv::run $id [list set received]] + ::coserv::run $id [list set received {}] + return $received +} + +proc ::dialog::listener {} { + variable port + return $port +} + +proc ::dialog::shutdown {} { + variable id + variable port + variable dtrace + + ::coserv::shutdown $id + + set id {} + set port {} + set dtrace {} + return +} + +# ### ### ### ######### ######### ######### diff --git a/tcllib/modules/devtools/receiver.crt b/tcllib/modules/devtools/receiver.crt new file mode 100644 index 0000000..80c4e59 --- /dev/null +++ b/tcllib/modules/devtools/receiver.crt @@ -0,0 +1,18 @@ +-----BEGIN CERTIFICATE----- +MIIC4TCCAkqgAwIBAgICEAEwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAkNB +MQswCQYDVQQIEwJCQzESMBAGA1UEBxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0Ex +DzANBgNVBAsTBlRjbGxpYjEXMBUGA1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkq +hkiG9w0BCQEWCnRjbGxpYkB0Y2EwHhcNMTMwMTIxMjE0NzAyWhcNMjMwMTE5MjE0 +NzAyWjCBgDELMAkGA1UEBhMCQ0ExCzAJBgNVBAgTAkJDMRIwEAYDVQQHEwlWYW5j +b3V2ZXIxDDAKBgNVBAoTA1RDQTEPMA0GA1UECxMGVGNsbGliMREwDwYDVQQDEwhS +ZWNlaXZlcjEeMBwGCSqGSIb3DQEJARYPcmVjZWl2ZXJAdGNsbGliMIGfMA0GCSqG +SIb3DQEBAQUAA4GNADCBiQKBgQDLjgsEvpLz8n2lumW8BrQ0mhnC5sAPSAhEUP5O +L+ePAt7j0r3gxYMQV+LkCHQIHOIcI5COoaG1kvc0EzX085ESgX2ksOeRCZ4c9mOY +cGbXfXlk3WGbzONPVUoI8OrrlggD4Xm5nRlg7RPsATzf4qxty5t3sH0XGzGYeyto +grvgkQIDAQABo2cwZTAfBgNVHSMEGDAWgBQh2mD6x23gAAI8h0CKNddvbEvhJTA0 +BgNVHSUELTArBggrBgEFBQcDAQYIKwYBBQUHAwIGCisGAQQBgjcKAwMGCWCGSAGG ++EIEATAMBgNVHRMBAf8EAjAAMA0GCSqGSIb3DQEBBAUAA4GBAE8ZtGhrr36XSQvM +e3bKS5NtiDd5EdNlbYJmx6y7mGYYev5NShXtY/Zj6B2Zs/Cb5gdxKJowHHLtjFpJ +L/7TMkuDGmXfZJOfoDo5kuJpRy6Cl0340fwhdFftMUV36COzgttvZRBoareT5ix0 +L+C7CHTyjD7J+FM8EYS09G/v5J7/ +-----END CERTIFICATE----- diff --git a/tcllib/modules/devtools/receiver.key b/tcllib/modules/devtools/receiver.key new file mode 100644 index 0000000..353e69a --- /dev/null +++ b/tcllib/modules/devtools/receiver.key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQDLjgsEvpLz8n2lumW8BrQ0mhnC5sAPSAhEUP5OL+ePAt7j0r3g +xYMQV+LkCHQIHOIcI5COoaG1kvc0EzX085ESgX2ksOeRCZ4c9mOYcGbXfXlk3WGb +zONPVUoI8OrrlggD4Xm5nRlg7RPsATzf4qxty5t3sH0XGzGYeytogrvgkQIDAQAB +AoGAS+WmjhpQyMy9tLGPhVAqmQJsYJORQSFmk7JvX8/U0yoK2X+WdNywRcO/Qa81 +NGEwnbVVDRmPJhiqO6x+DdtTV5zZBMECXbPpoRCno6rN1y66OflD0reW1EWkjDAs +BTZJ6jkMBYb/+A9hrO6rs9vOQSOuX78bv1EG9NzSR0kdlMECQQDngjy25H0G4s04 +/WIQ6ZxiqfF1dRoyr1qdsZ4SAEw81pr5EppkxOBmCxlFuTO19flb6vHV7ufAJ7PR +ChtFblQVAkEA4RbA66XPbfl9JC+QfGNavMKJXqTZJhvcndtc8104HHszJ3Jo0O8P +GK3tVrmpf3QmjkkbOxxYNIuyQTU/YAiNjQJAb8vUxf1Q4yJjOEIkOUaW3o5yq+YA +4LkNaVl8m/TI3BhGfkEdjcwFEUIK0kC9WAGQiXLLliPohkKl8yyOPtkogQJAc/vv +iP21tyt56m1//DiOBvoPIu+63UI6GjVw3g5I3ZQ2Nbtke1TT6Jmm1KtyxbQqMeNF +3t2qLdlWDvfLIkcF+QJBAJGyZC3Zym+BrLn8OJ6ceCt/lPp/baKzz883r2xoUCiF +HaJXRhbT563GYTBzFPgTmJO9AnVJBMkMM+Bt2R40JHk= +-----END RSA PRIVATE KEY----- diff --git a/tcllib/modules/devtools/testutilities.tcl b/tcllib/modules/devtools/testutilities.tcl new file mode 100644 index 0000000..f8f4ab1 --- /dev/null +++ b/tcllib/modules/devtools/testutilities.tcl @@ -0,0 +1,722 @@ +# -*- tcl -*- +# Testsuite utilities / boilerplate +# Copyright (c) 2006, Andreas Kupries <andreas_kupries@users.sourceforge.net> + +namespace eval ::tcllib::testutils { + variable self [file dirname [file join [pwd] [info script]]] + variable tcllib [file dirname $self] + variable tag "" + variable theEnv ; # Saved environment. +} + +# ### ### ### ######### ######### ######### +## Commands for common functions and boilerplate actions required by +## many testsuites of Tcllib modules and packages in a central place +## for easier maintenance. + +# ### ### ### ######### ######### ######### +## Declare the minimal version of Tcl required to run the package +## tested by this testsuite, and its dependencies. + +proc testsNeedTcl {version} { + # This command ensures that a minimum version of Tcl is used to + # run the tests in the calling testsuite. If the minimum is not + # met by the active interpreter we forcibly bail out of the + # testsuite calling the command. The command has to be called + # immediately after loading the utilities. + + if {[package vsatisfies [package provide Tcl] $version]} return + + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Requiring at least Tcl $version, have [package present Tcl]." + + # This causes a 'return' in the calling scope. + return -code return +} + +# ### ### ### ######### ######### ######### +## Declare the minimum version of Tcltest required to run the +## testsuite. + +proc testsNeedTcltest {version} { + # This command ensure that a minimum version of the Tcltest + # support package is used to run the tests in the calling + # testsuite. If the minimum is not met by the loaded package we + # forcibly bail out of the testsuite calling the command. The + # command has to be called after loading the utilities. The only + # command allowed to come before it is 'testNeedTcl' above. + + # Note that this command will try to load a suitable version of + # Tcltest if the package has not been loaded yet. + + if {[lsearch [namespace children] ::tcltest] == -1} { + if {![catch { + package require tcltest $version + }]} { + namespace import -force ::tcltest::* + InitializeTclTest + return + } + } elseif {[package vcompare [package present tcltest] $version] >= 0} { + InitializeTclTest + return + } + + puts " Aborting the tests found in [file tail [info script]]." + puts " Requiring at least tcltest $version, have [package present tcltest]" + + # This causes a 'return' in the calling scope. + return -code return +} + +proc testsNeed {name version} { + # This command ensures that a minimum version of package <name> is + # used to run the tests in the calling testsuite. If the minimum + # is not met by the active interpreter we forcibly bail out of the + # testsuite calling the command. The command has to be called + # immediately after loading the utilities. + + if {[catch { + package require $name $version + }]} { + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Requiring at least $name $version, package not found." + + return -code return + } + + if {[package vsatisfies [package present $name] $version]} return + + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Requiring at least $name $version, have [package present $name]." + + # This causes a 'return' in the calling scope. + return -code return +} + +# ### ### ### ######### ######### ######### + +## Save/restore the environment, for testsuites which have to +## manipulate it to (1) either achieve the effects they test +## for/against, or (2) to shield themselves against manipulation by +## the environment. We have examples for both in 'fileutil' (1), and +## 'doctools' (2). +## +## Saving is done automatically at the beginning of a test file, +## through this module. Restoration is done semi-automatically. We +## __cannot__ hook into the tcltest cleanup hook It is already used by +## all.tcl to transfer the information from the slave doing the actual +## tests to the master. Here the hook is only an alias, and +## unmodifiable. We create a new cleanup command which runs both our +## environment cleanup, and the regular one. All .test files are +## modified to use the new cleanup. + +proc ::tcllib::testutils::SaveEnvironment {} { + global env + variable theEnv [array get env] + return +} + +proc ::tcllib::testutils::RestoreEnvironment {} { + global env + variable theEnv + foreach k [array names env] { + unset env($k) + } + array set env $theEnv + return +} + +proc testsuiteCleanup {} { + ::tcllib::testutils::RestoreEnvironment + ::tcltest::cleanupTests + return +} + +proc array_unset {a {pattern *}} { + upvar 1 $a array + foreach k [array names array $pattern] { + unset array($k) + } + return +} + +# ### ### ### ######### ######### ######### +## Newer versions of the Tcltest support package for testsuite provide +## various features which make the creation and maintenance of +## testsuites much easier. I consider it important to have these +## features even if an older version of Tcltest is loaded. To this end +## we now provide emulations and implementations, conditional on the +## version of Tcltest found to be active. + +# ### ### ### ######### ######### ######### +## Easy definition and initialization of test constraints. + +proc InitializeTclTest {} { + global tcltestinit + if {[info exists tcltestinit] && $tcltestinit} return + set tcltestinit 1 + + if {![package vsatisfies [package provide tcltest] 2.0]} { + # Tcltest 2.0+ provides a documented public API to define and + # initialize a test constraint. For earlier versions of the + # package the user has to directly set a non-public undocumented + # variable in the package's namespace. We create a command doing + # this and emulating the public API. + + proc ::tcltest::testConstraint {c args} { + variable testConstraints + if {[llength $args] < 1} { + if {[info exists testConstraints($c)]} { + return $testConstraints($c) + } else { + return {} + } + } else { + set testConstraints($c) [lindex $args 0] + } + return + } + + namespace eval ::tcltest { + namespace export testConstraint + } + uplevel \#0 {namespace import -force ::tcltest::*} + } + + # ### ### ### ######### ######### ######### + ## Define a set of standard constraints + + ::tcltest::testConstraint tcl8.3only \ + [expr {![package vsatisfies [package provide Tcl] 8.4]}] + + ::tcltest::testConstraint tcl8.3plus \ + [expr {[package vsatisfies [package provide Tcl] 8.3]}] + + ::tcltest::testConstraint tcl8.4plus \ + [expr {[package vsatisfies [package provide Tcl] 8.4]}] + + ::tcltest::testConstraint tcl8.5plus \ + [expr {[package vsatisfies [package provide Tcl] 8.5]}] + + ::tcltest::testConstraint tcl8.6plus \ + [expr {[package vsatisfies [package provide Tcl] 8.6]}] + + ::tcltest::testConstraint tcl8.4minus \ + [expr {![package vsatisfies [package provide Tcl] 8.5]}] + + ::tcltest::testConstraint tcl8.5minus \ + [expr {![package vsatisfies [package provide Tcl] 8.6]}] + + # ### ### ### ######### ######### ######### + ## Cross-version code for the generation of the error messages created + ## by Tcl procedures when called with the wrong number of arguments, + ## either too many, or not enough. + + if {[package vsatisfies [package provide Tcl] 8.6]} { + # 8.6+ + proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { + if {[string match args [lindex $argList end]]} { + set argList [lreplace $argList end end ?arg ...?] + } + if {$argList != {}} {set argList " $argList"} + set msg "wrong # args: should be \"$functionName$argList\"" + return $msg + } + + proc ::tcltest::tooManyArgs {functionName argList} { + # create a different message for functions with no args + if {[llength $argList]} { + if {[string match args [lindex $argList end]]} { + set argList [lreplace $argList end end ?arg ...?] + } + set msg "wrong # args: should be \"$functionName $argList\"" + } else { + set msg "wrong # args: should be \"$functionName\"" + } + return $msg + } + } elseif {[package vsatisfies [package provide Tcl] 8.5]} { + # 8.5 + proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { + if {[string match args [lindex $argList end]]} { + set argList [lreplace $argList end end ...] + } + if {$argList != {}} {set argList " $argList"} + set msg "wrong # args: should be \"$functionName$argList\"" + return $msg + } + + proc ::tcltest::tooManyArgs {functionName argList} { + # create a different message for functions with no args + if {[llength $argList]} { + if {[string match args [lindex $argList end]]} { + set argList [lreplace $argList end end ...] + } + set msg "wrong # args: should be \"$functionName $argList\"" + } else { + set msg "wrong # args: should be \"$functionName\"" + } + return $msg + } + } elseif {[package vsatisfies [package provide Tcl] 8.4]} { + # 8.4+ + proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { + if {$argList != {}} {set argList " $argList"} + set msg "wrong # args: should be \"$functionName$argList\"" + return $msg + } + + proc ::tcltest::tooManyArgs {functionName argList} { + # create a different message for functions with no args + if {[llength $argList]} { + set msg "wrong # args: should be \"$functionName $argList\"" + } else { + set msg "wrong # args: should be \"$functionName\"" + } + return $msg + } + } else { + # 8.2+ + proc ::tcltest::wrongNumArgs {functionName argList missingIndex} { + set msg "no value given for parameter " + append msg "\"[lindex $argList $missingIndex]\" to " + append msg "\"$functionName\"" + return $msg + } + + proc ::tcltest::tooManyArgs {functionName argList} { + set msg "called \"$functionName\" with too many arguments" + return $msg + } + } + + # ### ### ### ######### ######### ######### + ## tclTest::makeFile result API changed for 2.0 + + if {![package vsatisfies [package provide tcltest] 2.0]} { + + # The 'makeFile' in Tcltest 1.0 returns a list of all the + # paths generated so far, whereas the 'makeFile' in 2.0+ + # returns only the path of the newly generated file. We + # standardize on the more useful behaviour of 2.0+. If 1.x is + # present we have to create an emulation layer to get the + # wanted result. + + # 1.0 is not fully correctly described. If the file was + # created before no list is returned at all. We force things + # by adding a line to the old procedure which makes the result + # unconditional (the name of the file/dir created). + + # The same change applies to 'makeDirectory' + + if {![llength [info commands ::tcltest::makeFile_1]]} { + # Marker first. + proc ::tcltest::makeFile_1 {args} {} + + # Extend procedures with command to return the required + # full name. + proc ::tcltest::makeFile {contents name} \ + [info body ::tcltest::makeFile]\n[list set fullName] + + proc ::tcltest::makeDirectory {name} \ + [info body ::tcltest::makeDirectory]\n[list set fullName] + + # Re-export + namespace eval ::tcltest { + namespace export makeFile makeDirectory + } + uplevel \#0 {namespace import -force ::tcltest::*} + } + } + + # ### ### ### ######### ######### ######### + ## Extended functionality, creation of binary temp. files. + ## Also creation of paths for temp. files + + proc ::tcltest::makeBinaryFile {data f} { + set path [makeFile {} $f] + set ch [open $path w] + fconfigure $ch -translation binary + puts -nonewline $ch $data + close $ch + return $path + } + + proc ::tcltest::tempPath {path} { + variable temporaryDirectory + return [file join $temporaryDirectory $path] + } + + namespace eval ::tcltest { + namespace export wrongNumArgs tooManyArgs + namespace export makeBinaryFile tempPath + } + uplevel \#0 {namespace import -force ::tcltest::*} + return +} + +# ### ### ### ######### ######### ######### +## Command to construct wrong/args messages for Snit methods. + +proc snitErrors {} { + if {[package vsatisfies [package provide snit] 2]} { + # Snit 2.0+ + + proc snitWrongNumArgs {obj method arglist missingIndex} { + regsub {^.*Snit_method} $method {} method + tcltest::wrongNumArgs "$obj $method" $arglist $missingIndex + } + + proc snitTooManyArgs {obj method arglist} { + regsub {^.*Snit_method} $method {} method + tcltest::tooManyArgs "$obj $method" $arglist + } + + } else { + proc snitWrongNumArgs {obj method arglist missingIndex} { + incr missingIndex 4 + tcltest::wrongNumArgs "$method" [linsert $arglist 0 \ + type selfns win self] $missingIndex + } + + proc snitTooManyArgs {obj method arglist} { + tcltest::tooManyArgs "$method" [linsert $arglist 0 \ + type selfns win self] + } + } +} + +# ### ### ### ######### ######### ######### +## Commands to load files from various locations within the local +## Tcllib, and the loading of local Tcllib packages. None of them goes +## through the auto-loader, nor the regular package management, to +## avoid contamination of the testsuite by packages and code outside +## of the Tcllib under test. + +proc localPath {fname} { + return [file join $::tcltest::testsDirectory $fname] +} + +proc tcllibPath {fname} { + return [file join $::tcllib::testutils::tcllib $fname] +} + +proc useLocalFile {fname} { + return [uplevel 1 [list source [localPath $fname]]] +} + +proc useTcllibFile {fname} { + return [uplevel 1 [list source [tcllibPath $fname]]] +} + +proc use {fname pname args} { + set nsname ::$pname + if {[llength $args]} {set nsname [lindex $args 0]} + + package forget $pname + catch {namespace delete $nsname} + + if {[catch { + uplevel 1 [list useTcllibFile $fname] + } msg]} { + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Error in [file tail $fname]: $msg" + return -code error "" + } + + puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" + return +} + +proc useKeep {fname pname args} { + set nsname ::$pname + if {[llength $args]} {set nsname [lindex $args 0]} + + package forget $pname + + # Keep = Keep the existing namespace of the package. + # = Do not delete it. This is required if the + # namespace contains commands created by a + # binary package, like 'tcllibc'. They cannot + # be re-created. + ## + ## catch {namespace delete $nsname} + + if {[catch { + uplevel 1 [list useTcllibFile $fname] + } msg]} { + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Error in [file tail $fname]: $msg" + return -code error "" + } + + puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" + return +} + +proc useLocal {fname pname args} { + set nsname ::$pname + if {[llength $args]} {set nsname [lindex $args 0]} + + package forget $pname + catch {namespace delete $nsname} + + if {[catch { + uplevel 1 [list useLocalFile $fname] + } msg]} { + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Error in [file tail $fname]: $msg" + return -code error "" + } + + puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" + return +} + +proc useLocalKeep {fname pname args} { + set nsname ::$pname + if {[llength $args]} {set nsname [lindex $args 0]} + + package forget $pname + + # Keep = Keep the existing namespace of the package. + # = Do not delete it. This is required if the + # namespace contains commands created by a + # binary package, like 'tcllibc'. They cannot + # be re-created. + ## + ## catch {namespace delete $nsname} + + if {[catch { + uplevel 1 [list useLocalFile $fname] + } msg]} { + puts " Aborting the tests found in \"[file tail [info script]]\"" + puts " Error in [file tail $fname]: $msg" + return -code error "" + } + + puts "$::tcllib::testutils::tag [list $pname] [package present $pname]" + return +} + +proc useAccel {acc fname pname args} { + set use [expr {$acc ? "useKeep" : "use"}] + uplevel 1 [linsert $args 0 $use $fname $pname] +} + +proc support {script} { + InitializeTclTest + set ::tcllib::testutils::tag "-" + if {[catch { + uplevel 1 $script + } msg]} { + set prefix "SETUP Error (Support): " + puts $prefix[join [split $::errorInfo \n] "\n$prefix"] + + return -code return + } + return +} + +proc testing {script} { + InitializeTclTest + set ::tcllib::testutils::tag "*" + if {[catch { + uplevel 1 $script + } msg]} { + set prefix "SETUP Error (Testing): " + puts $prefix[join [split $::errorInfo \n] "\n$prefix"] + + return -code return + } + return +} + +proc useTcllibC {} { + set index [tcllibPath tcllibc/pkgIndex.tcl] + if {![file exists $index]} { + # Might have an external tcllibc + if {![catch { + package require tcllibc + }]} { + puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]" + puts "$::tcllib::testutils::tag tcllibc = [package ifneeded tcllibc [package present tcllibc]]" + return 1 + } + + return 0 + } + + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + + package require tcllibc + + puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]" + puts "$::tcllib::testutils::tag tcllibc = [package ifneeded tcllibc [package present tcllibc]]" + return 1 +} + +# ### ### ### ######### ######### ######### +## General utilities + +# - dictsort - +# +# Sort a dictionary by its keys. I.e. reorder the contents of the +# dictionary so that in its list representation the keys are found in +# ascending alphabetical order. In other words, this command creates +# a canonical list representation of the input dictionary, suitable +# for direct comparison. +# +# Arguments: +# dict: The dictionary to sort. +# +# Result: +# The canonical representation of the dictionary. + +proc dictsort {dict} { + array set a $dict + set out [list] + foreach key [lsort [array names a]] { + lappend out $key $a($key) + } + return $out +} + +# ### ### ### ######### ######### ######### +## Putting strings together, if they cannot be expressed easily as one +## string due to quoting problems. + +proc cat {args} { + return [join $args ""] +} + +# ### ### ### ######### ######### ######### +## Mini-logging facility, can also be viewed as an accumulator for +## complex results. +# +# res! : clear accumulator. +# res+ : add arguments to accumulator. +# res? : query contents of accumulator. +# res?lines : query accumulator and format as +# multiple lines, one per list element. + +proc res! {} { + variable result {} + return +} + +proc res+ {args} { + variable result + lappend result $args + return +} + +proc res? {} { + variable result + return $result +} + +proc res?lines {} { + return [join [res?] \n] +} + +# ### ### ### ######### ######### ######### +## Helper commands to deal with packages +## which have multiple implementations, i.e. +## their pure Tcl base line and one or more +## accelerators. We are assuming a specific +## API for accessing the data about available +## accelerators, switching between them, etc. + +# == Assumed API == +# +# KnownImplementations -- +# Returns list of all known implementations. +# +# Implementations -- +# Returns list of activated implementations. +# A subset of 'KnownImplementations' +# +# Names -- +# Returns dict mapping all known implementations +# to human-readable strings for output during a +# test run +# +# LoadAccelerator accel -- +# Tries to make the implementation named +# 'accel' available for use. Result is boolean. +# True indicates a successful activation. +# +# SwitchTo accel -- +# Activate the implementation named 'accel'. +# The empty string disables all implementations. + +proc TestAccelInit {namespace} { + # Disable all implementations ... Base state. + ${namespace}::SwitchTo {} + + # List the implementations. + array set map [${namespace}::Names] + foreach e [${namespace}::KnownImplementations] { + if {[${namespace}::LoadAccelerator $e]} { + puts "> $map($e)" + } + } + return +} + +proc TestAccelDo {namespace var script} { + upvar 1 $var impl + foreach impl [${namespace}::Implementations] { + ${namespace}::SwitchTo $impl + uplevel 1 $script + } + return +} + +proc TestAccelExit {namespace} { + # Reset the system to a fully inactive state. + ${namespace}::SwitchTo {} + return +} + +# ### ### ### ######### ######### ######### +## + +proc TestFiles {pattern} { + if {[package vsatisfies [package provide Tcl] 8.3]} { + # 8.3+ -directory ok + set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern] + } else { + # 8.2 or less, no -directory + set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]] + } + foreach f [lsort -dict $flist] { + uplevel 1 [list source $f] + } + return +} + +proc TestFilesGlob {pattern} { + if {[package vsatisfies [package provide Tcl] 8.3]} { + # 8.3+ -directory ok + set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern] + } else { + # 8.2 or less, no -directory + set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]] + } + return [lsort -dict $flist] +} + +# ### ### ### ######### ######### ######### +## + +::tcllib::testutils::SaveEnvironment + +# ### ### ### ######### ######### ######### +package provide tcllib::testutils 1.2 +puts "- tcllib::testutils [package present tcllib::testutils]" +return diff --git a/tcllib/modules/devtools/transmitter.crt b/tcllib/modules/devtools/transmitter.crt new file mode 100644 index 0000000..69c5027 --- /dev/null +++ b/tcllib/modules/devtools/transmitter.crt @@ -0,0 +1,18 @@ +-----BEGIN CERTIFICATE----- +MIIC5zCCAlCgAwIBAgICEAAwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAkNB +MQswCQYDVQQIEwJCQzESMBAGA1UEBxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0Ex +DzANBgNVBAsTBlRjbGxpYjEXMBUGA1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkq +hkiG9w0BCQEWCnRjbGxpYkB0Y2EwHhcNMTMwMTIxMjE0NjUxWhcNMjMwMTE5MjE0 +NjUxWjCBhjELMAkGA1UEBhMCQ0ExCzAJBgNVBAgTAkJDMRIwEAYDVQQHEwlWYW5j +b3V2ZXIxDDAKBgNVBAoTA1RDQTEPMA0GA1UECxMGVGNsbGliMRQwEgYDVQQDEwtU +cmFuc21pdHRlcjEhMB8GCSqGSIb3DQEJARYSdHJhbnNtaXR0ZXJAdGNsbGliMIGf +MA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC3jpcKzCWtt5sKSHDXO34jO2G+DfbY +OGrgPu/YaqzUxVxsFSyK56jBNa1GldVA+fOVO8KDX5UOc8KKlz+AhGq5YceGQ4Cj +WTK3YHUeVOeBqszqphG2D5vlvFf2dqIUZ4N8a+Ah+5gwtCwBo7gPA+PxJFaTWRtG +0nN4lWTLjeF9uwIDAQABo2cwZTAfBgNVHSMEGDAWgBQh2mD6x23gAAI8h0CKNddv +bEvhJTA0BgNVHSUELTArBggrBgEFBQcDAQYIKwYBBQUHAwIGCisGAQQBgjcKAwMG +CWCGSAGG+EIEATAMBgNVHRMBAf8EAjAAMA0GCSqGSIb3DQEBBAUAA4GBAA9Ec5V0 +wQCOSr2wz2qzWOQlw2KGtBCJaM/vckt5YJmpHIkp9cVP/tlHPG9qzG9VfQs4nOKa +wUjZ8xVt6kKA8gWbBm3mFSsI2JhT/q77FCWoMC56d7cLqqU6D2fmC1ksNMljhJ5n +UNgvspAEL5Txryh9VRYNRUZGjowquXXYUWht +-----END CERTIFICATE----- diff --git a/tcllib/modules/devtools/transmitter.key b/tcllib/modules/devtools/transmitter.key new file mode 100644 index 0000000..164db5d --- /dev/null +++ b/tcllib/modules/devtools/transmitter.key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQC3jpcKzCWtt5sKSHDXO34jO2G+DfbYOGrgPu/YaqzUxVxsFSyK +56jBNa1GldVA+fOVO8KDX5UOc8KKlz+AhGq5YceGQ4CjWTK3YHUeVOeBqszqphG2 +D5vlvFf2dqIUZ4N8a+Ah+5gwtCwBo7gPA+PxJFaTWRtG0nN4lWTLjeF9uwIDAQAB +AoGAQlTp6kH5v7wg7+dbt7vNCmhUGv0q3doNbTnxLJDoIf+sNXa1YQD0L9X45xAQ +P2nUB3LQCO+Kiu10OOcNUKEJe5WuIKGnD3BZkwyGOngJibYI8D0KXfqQRK9z2cgV +GfsFXa5Dv1fK7vOM+zBVEJxmcsOqlHO6h8quwhRd7Kuu+/ECQQDjCTVgWgTt1Gq2 +1ph0iLns1LJbz8RPtM+7FgD1wUvixB5ItTTP5dI8j2o7dUb/ylGHnUNG4FruFGS5 +FHFgi1rDAkEAzvllogyGGsMgKLaxZHNiwQsUU8j0PI3y2EX0udLOVSvjDePbzg00 +GYx0rFM+pQUE12TQaIsykp0YCuGDB7vxqQJAKQw8K0x7Qai7Fo2cCM3Dl88o5DKf +Uq3lNPUYfVZSaxB8TTb98myh4zMmyNM+X/brYLKNPF5J8mubfl701Li9UwJAcgo8 +k5Mu+OP2fjhbeauSCCegpaGd4RedbMju1MxwX8F0s5yO6fOgd0tKpgCgDbC8QCoO +Iuw/i0T/kE89MS+/MQJBANIMifrdikFda4M8eGjRA/ekvZ0UD8ELgOs8eIBJZkvX +1EAdlgtFAKvNW3dzu8uPRODQ1pKZoQSnOrMhe+sqzdo= +-----END RSA PRIVATE KEY----- |