Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

5 files changed, 506 insertions, 0 deletions

diff --git a/tcllib/modules/uuid/ChangeLog b/tcllib/modules/uuid/ChangeLog
new file mode 100644
index 0000000..9b862ef
--- /dev/null
+++ b/tcllib/modules/uuid/ChangeLog
@@ -0,0 +1,110 @@
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2012-11-19  Andreas Kupries  <andreask@activestate.com>
+
+	* uuid.tcl (::uuid::generate_tcl): Accepted patch by Sean Woods
+	* uuid.man: caching the host information part of the uuid. Avoids
+	* pkgIndex.tcl: hammering the network stack for hostname and
+	  related information. Bumped version to 1.0.2.
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.13 ========================
+	* 
+
+2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.12 ========================
+	* 
+
+2008-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11.1 ========================
+	* 
+
+2008-10-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11 ========================
+	* 
+
+2007-09-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.10 ========================
+	* 
+
+2007-03-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* uuid.man: Fixed all warnings due to use of now deprecated
+	  commands. Added a section about how to give feedback.
+
+2006-10-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.9 ========================
+	* 
+
+2006-01-26  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* uuid.test: More boilerplate simplified via use of test support.
+
+2006-01-19  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* uuid.test: Hooked into the new common test support code.
+
+2005-10-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.8 ========================
+	* 
+
+2005-10-05  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* uuid.test:  Ensure we test all implementations.
+	* uuid.tcl:   Updated critcl code to work with msvc.
+
+2005-09-05  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* uuid.tcl: Bug #1150714 - opening a server socket may raise a
+	warning message box on WinXP firewall. Instead call the ipconfig
+	utility and use the result on windows.
+
+2005-02-10  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* uuid.tcl: Fixed missing include in the critcl code.
+
+2004-10-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.7 ========================
+	* 
+
+2004-07-12  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* uuid.tcl:   Added a critcl version for generating uuids on Win32.
+
+2004-07-08  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* uuid.tcl:   Changed uuid compare to uuid equal (bug #987305)
+	* uuid.man:
+	* uuid.test:
+	
+	* uuid.tcl:   Package for UUID generation and comparison.
+	* uuid.test:
+	* uuid.man:
+	
+
diff --git a/tcllib/modules/uuid/pkgIndex.tcl b/tcllib/modules/uuid/pkgIndex.tcl
new file mode 100644
index 0000000..af4447e
--- /dev/null
+++ b/tcllib/modules/uuid/pkgIndex.tcl
@@ -0,0 +1,8 @@
+# pkgIndex.tcl - 
+#
+# uuid package index file
+#
+# $Id: pkgIndex.tcl,v 1.3 2012/11/19 19:28:24 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded uuid 1.0.5 [list source [file join $dir uuid.tcl]]
diff --git a/tcllib/modules/uuid/uuid.man b/tcllib/modules/uuid/uuid.man
new file mode 100644
index 0000000..97b4541
--- /dev/null
+++ b/tcllib/modules/uuid/uuid.man
@@ -0,0 +1,54 @@
+[vset UUID_VERSION 1.0.4]
+[manpage_begin uuid n [vset UUID_VERSION]]
+[keywords GUID]
+[keywords UUID]
+[moddesc {uuid}]
+[copyright {2004, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[titledesc {UUID generation and comparison}]
+[category  {Hashes, checksums, and encryption}]
+[require Tcl 8.5]
+[require uuid [opt [vset UUID_VERSION]]]
+[description]
+[para]
+
+This package provides a generator of universally unique identifiers
+(UUID) also known as globally unique identifiers (GUID). This
+implementation follows the draft specification from (1) although this
+is actually an expired draft document.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::uuid::uuid generate"]]
+
+Creates a type 4 uuid by MD5 hashing a number of bits of variant data
+including the time and hostname.
+Returns the string representation of the new uuid.
+
+[call [cmd "::uuid::uuid equal"] [arg "id1"] [arg "id2"]]
+
+Compares two uuids and returns true if both arguments are the same uuid.
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% uuid::uuid generate
+b12dc22c-5c36-41d2-57da-e29d0ef5839c
+}]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+    Paul J. Leach, "UUIDs and GUIDs", February 1998.
+    ([uri http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt])
+
+[list_end]
+
+[vset CATEGORY uuid]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/uuid/uuid.tcl b/tcllib/modules/uuid/uuid.tcl
new file mode 100644
index 0000000..0c5295e
--- /dev/null
+++ b/tcllib/modules/uuid/uuid.tcl
@@ -0,0 +1,238 @@
+# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# UUIDs are 128 bit values that attempt to be unique in time and space.
+#
+# Reference:
+#   http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
+#
+# uuid: scheme:
+# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
+#
+# Usage: uuid::uuid generate
+#        uuid::uuid equal $idA $idB
+
+package require Tcl 8.5
+
+namespace eval uuid {
+    variable accel
+    array set accel {critcl 0}
+
+    namespace export uuid
+
+    variable uid
+    if {![info exists uid]} {
+        set uid 1
+    }
+
+    proc K {a b} {set a}
+}
+
+###
+# Optimization
+# Caches machine info after the first pass
+###
+
+proc ::uuid::generate_tcl_machinfo {} {
+  variable machinfo
+  if {[info exists machinfo]} {
+    return $machinfo
+  }
+  lappend machinfo [clock seconds]; # timestamp
+  lappend machinfo [clock clicks];  # system incrementing counter
+  lappend machinfo [info hostname]; # spatial unique id (poor)
+  lappend machinfo [pid];           # additional entropy
+  lappend machinfo [array get ::tcl_platform]
+  if {[catch {package require nettool}]} {
+    # More spatial information -- better than hostname.
+    # bug 1150714: opening a server socket may raise a warning messagebox
+    #   with WinXP firewall, using ipconfig will return all IP addresses
+    #   including ipv6 ones if available. ipconfig is OK on win98+
+    if {[string equal $::tcl_platform(platform) "windows"]} {
+      catch {exec ipconfig} config
+      lappend machinfo $config
+    } else {
+      catch {
+          set s [socket -server void -myaddr [info hostname] 0]
+          K [fconfigure $s -sockname] [close $s]
+      } r
+      lappend machinfo $r
+    }
+  
+    if {[package provide Tk] != {}} {
+      lappend machinfo [winfo pointerxy .]
+      lappend machinfo [winfo id .]
+    }
+  } else {
+    ###
+    # If the nettool package works on this platform
+    # use the stream of hardware ids from it
+    ###
+    lappend machinfo {*}[::nettool::hwid_list]
+  }
+  return $machinfo
+}
+
+# Generates a binary UUID as per the draft spec. We generate a pseudo-random
+# type uuid (type 4). See section 3.4
+#
+proc ::uuid::generate_tcl {} {
+    package require md5 2
+    variable uid
+    
+    set tok [md5::MD5Init]
+    md5::MD5Update $tok [incr uid];      # package incrementing counter 
+    foreach string [generate_tcl_machinfo] {
+      md5::MD5Update $tok $string
+    }
+    set r [md5::MD5Final $tok]
+    binary scan $r c* r
+    
+    # 3.4: set uuid versioning fields
+    lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
+    lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
+    
+    return [binary format c* $r]
+}
+
+if {[string equal $tcl_platform(platform) "windows"] 
+        && [package provide critcl] != {}} {
+    namespace eval uuid {
+        critcl::ccode {
+            #define WIN32_LEAN_AND_MEAN
+            #define STRICT
+            #include <windows.h>
+            #include <ole2.h>
+            typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
+            typedef const unsigned char cu_char;
+        }
+        critcl::cproc generate_c {Tcl_Interp* interp} ok {
+            HRESULT hr = S_OK;
+            int r = TCL_OK;
+            UUID uuid = {0};
+            HMODULE hLib;
+            LPFNUUIDCREATE lpfnUuidCreate = NULL;
+
+            hLib = LoadLibrary(_T("rpcrt4.dll"));
+            if (hLib)
+                lpfnUuidCreate = (LPFNUUIDCREATE)
+                    GetProcAddress(hLib, "UuidCreate");
+            if (lpfnUuidCreate) {
+                Tcl_Obj *obj;
+                lpfnUuidCreate(&uuid);
+                obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
+                Tcl_SetObjResult(interp, obj);
+            } else {
+                Tcl_SetResult(interp, "error: failed to create a guid",
+                              TCL_STATIC);
+                r = TCL_ERROR;
+            }
+            return r;
+        }
+    }
+}
+
+# Convert a binary uuid into its string representation.
+#
+proc ::uuid::tostring {uuid} {
+    binary scan $uuid H* s
+    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
+        append r [string range $s $a $b] -
+    }
+    return [string tolower [string trimright $r -]]
+}
+
+# Convert a string representation of a uuid into its binary format.
+#
+proc ::uuid::fromstring {uuid} {
+    return [binary format H* [string map {- {}} $uuid]]
+}
+
+# Compare two uuids for equality.
+#
+proc ::uuid::equal {left right} {
+    set l [fromstring $left]
+    set r [fromstring $right]
+    return [string equal $l $r]
+}
+
+# Call our generate uuid implementation
+proc ::uuid::generate {} {
+    variable accel
+    if {$accel(critcl)} {
+        return [generate_c]
+    } else {
+        return [generate_tcl]
+    }
+}
+
+# uuid generate -> string rep of a new uuid
+# uuid equal uuid1 uuid2
+#
+proc uuid::uuid {cmd args} {
+    switch -exact -- $cmd {
+        generate {
+            if {[llength $args] != 0} {
+                return -code error "wrong # args:\
+                    should be \"uuid generate\""
+            }
+            return [tostring [generate]]
+        }
+        equal {
+            if {[llength $args] != 2} {
+                return -code error "wrong \# args:\
+                    should be \"uuid equal uuid1 uuid2\""
+            }
+            return [eval [linsert $args 0 equal]]
+        }
+        default {
+            return -code error "bad option \"$cmd\":\
+                must be generate or equal"
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::uuid::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        critcl {
+            if {![catch {package require tcllibc}]} {
+                set r [expr {[info commands ::uuid::generate_c] != {}}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator package:\
+                must be one of [join [array names accel] {, }]"
+        }
+    }
+    set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::uuid {
+    variable e {}
+    foreach e {critcl} {
+        if {[LoadAccelerator $e]} break
+    }
+    unset e
+}
+
+package provide uuid 1.0.5
+
+# -------------------------------------------------------------------------
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/uuid/uuid.test b/tcllib/modules/uuid/uuid.test
new file mode 100644
index 0000000..e88b19f
--- /dev/null
+++ b/tcllib/modules/uuid/uuid.test
@@ -0,0 +1,96 @@
+# uuid.test:  tests for the uuid package                       -*- tcl -*-
+#
+# $Id: uuid.test,v 1.6 2006/10/09 21:41:42 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+	[file dirname [file dirname [file join [pwd] [info script]]]] \
+	devtools testutilities.tcl]
+
+testsNeedTcl     8.5
+testsNeedTcltest 1.0
+
+testing {
+    useLocal uuid.tcl uuid
+}
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+
+array set preserve [array get ::uuid::accel]
+
+proc implementations {} {
+    variable ::uuid::accel
+    foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+    lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+    variable ::uuid::accel
+    foreach e [array names accel] { set accel($e) 0 }
+    if {[string compare "tcl" $impl] != 0} {
+        set accel($impl) 1
+    }
+}
+
+proc reset_implementation {} {
+    variable ::uuid::accel
+    array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+# Setup any constraints
+#
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+# -------------------------------------------------------------------------
+
+if {[::uuid::LoadAccelerator critcl]} {
+    puts "> critcl based"
+}
+puts "> pure Tcl"
+
+# -------------------------------------------------------------------------
+
+foreach impl [implementations] {
+    select_implementation $impl
+
+    test uuid-1.0-$impl "uuid requires args" {
+        list [catch {uuid::uuid} msg]
+    } {1}
+    
+    test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" {
+        list [catch {string length [uuid::uuid generate]} msg] $msg
+    } {0 36}
+    
+    test uuid-1.2-$impl "uuid comparison of uuid with self should be true" {
+        list [catch {
+            set a [uuid::uuid generate]
+            uuid::uuid equal $a $a
+        } msg] $msg
+    } {0 1}
+    
+    test uuid-1.3-$impl "uuid comparison of two different\
+        uuids should be false" {
+        list [catch {
+            set a [uuid::uuid generate]
+            set b [uuid::uuid generate]
+            uuid::uuid equal $a $b
+        } msg] $msg
+    } {0 0}
+    
+    reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# -------------------------------------------------------------------------
+# Local Variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End: