1# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# UUIDs are 128 bit values that attempt to be unique in time and space. 4# 5# Reference: 6# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt 7# 8# uuid: scheme: 9# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html 10# 11# Usage: uuid::uuid generate 12# uuid::uuid equal $idA $idB 13 14namespace eval uuid { 15 variable version 1.0.1 16 variable accel 17 array set accel {critcl 0} 18 19 namespace export uuid 20 21 variable uid 22 if {![info exists uid]} { 23 set uid 1 24 } 25 26 if {[package vcompare [package provide Tcl] 8.4] < 0} { 27 package require struct::list 28 interp alias {} ::uuid::lset {} ::struct::list::lset 29 } 30 31 proc K {a b} {set a} 32} 33 34# Generates a binary UUID as per the draft spec. We generate a pseudo-random 35# type uuid (type 4). See section 3.4 36# 37proc ::uuid::generate_tcl {} { 38 package require md5 2 39 variable uid 40 41 set tok [md5::MD5Init] 42 md5::MD5Update $tok [clock seconds]; # timestamp 43 md5::MD5Update $tok [clock clicks]; # system incrementing counter 44 md5::MD5Update $tok [incr uid]; # package incrementing counter 45 md5::MD5Update $tok [info hostname]; # spatial unique id (poor) 46 md5::MD5Update $tok [pid]; # additional entropy 47 md5::MD5Update $tok [array get ::tcl_platform] 48 49 # More spatial information -- better than hostname. 50 # bug 1150714: opening a server socket may raise a warning messagebox 51 # with WinXP firewall, using ipconfig will return all IP addresses 52 # including ipv6 ones if available. ipconfig is OK on win98+ 53 if {[string equal $::tcl_platform(platform) "windows"]} { 54 catch {exec ipconfig} config 55 md5::MD5Update $tok $config 56 } else { 57 catch { 58 set s [socket -server void -myaddr [info hostname] 0] 59 K [fconfigure $s -sockname] [close $s] 60 } r 61 md5::MD5Update $tok $r 62 } 63 64 if {[package provide Tk] != {}} { 65 md5::MD5Update $tok [winfo pointerxy .] 66 md5::MD5Update $tok [winfo id .] 67 } 68 69 set r [md5::MD5Final $tok] 70 binary scan $r c* r 71 72 # 3.4: set uuid versioning fields 73 lset r 8 [expr {([lindex $r 8] & 0x7F) | 0x40}] 74 lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] 75 76 return [binary format c* $r] 77} 78 79if {[string equal $tcl_platform(platform) "windows"] 80 && [package provide critcl] != {}} { 81 namespace eval uuid { 82 critcl::ccode { 83 #define WIN32_LEAN_AND_MEAN 84 #define STRICT 85 #include <windows.h> 86 #include <ole2.h> 87 typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); 88 typedef const unsigned char cu_char; 89 } 90 critcl::cproc generate_c {Tcl_Interp* interp} ok { 91 HRESULT hr = S_OK; 92 int r = TCL_OK; 93 UUID uuid = {0}; 94 HMODULE hLib; 95 LPFNUUIDCREATE lpfnUuidCreate = NULL; 96 97 hLib = LoadLibrary(_T("rpcrt4.dll")); 98 if (hLib) 99 lpfnUuidCreate = (LPFNUUIDCREATE) 100 GetProcAddress(hLib, "UuidCreate"); 101 if (lpfnUuidCreate) { 102 Tcl_Obj *obj; 103 lpfnUuidCreate(&uuid); 104 obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); 105 Tcl_SetObjResult(interp, obj); 106 } else { 107 Tcl_SetResult(interp, "error: failed to create a guid", 108 TCL_STATIC); 109 r = TCL_ERROR; 110 } 111 return r; 112 } 113 } 114} 115 116# Convert a binary uuid into its string representation. 117# 118proc ::uuid::tostring {uuid} { 119 binary scan $uuid H* s 120 foreach {a b} {0 7 8 11 12 15 16 19 20 end} { 121 append r [string range $s $a $b] - 122 } 123 return [string tolower [string trimright $r -]] 124} 125 126# Convert a string representation of a uuid into its binary format. 127# 128proc ::uuid::fromstring {uuid} { 129 return [binary format H* [string map {- {}} $uuid]] 130} 131 132# Compare two uuids for equality. 133# 134proc ::uuid::equal {left right} { 135 set l [fromstring $left] 136 set r [fromstring $right] 137 return [string equal $l $r] 138} 139 140# Call our generate uuid implementation 141proc ::uuid::generate {} { 142 variable accel 143 if {$accel(critcl)} { 144 return [generate_c] 145 } else { 146 return [generate_tcl] 147 } 148} 149 150# uuid generate -> string rep of a new uuid 151# uuid equal uuid1 uuid2 152# 153proc uuid::uuid {cmd args} { 154 switch -exact -- $cmd { 155 generate { 156 if {[llength $args] != 0} { 157 return -code error "wrong # args:\ 158 should be \"uuid generate\"" 159 } 160 return [tostring [generate]] 161 } 162 equal { 163 if {[llength $args] != 2} { 164 return -code error "wrong \# args:\ 165 should be \"uuid equal uuid1 uuid2\"" 166 } 167 return [eval [linsert $args 0 equal]] 168 } 169 default { 170 return -code error "bad option \"$cmd\":\ 171 must be generate or equal" 172 } 173 } 174} 175 176# ------------------------------------------------------------------------- 177 178# LoadAccelerator -- 179# 180# This package can make use of a number of compiled extensions to 181# accelerate the digest computation. This procedure manages the 182# use of these extensions within the package. During normal usage 183# this should not be called, but the test package manipulates the 184# list of enabled accelerators. 185# 186proc ::uuid::LoadAccelerator {name} { 187 variable accel 188 set r 0 189 switch -exact -- $name { 190 critcl { 191 if {![catch {package require tcllibc}]} { 192 set r [expr {[info command ::uuid::generate_c] != {}}] 193 } 194 } 195 default { 196 return -code error "invalid accelerator package:\ 197 must be one of [join [array names accel] {, }]" 198 } 199 } 200 set accel($name) $r 201} 202 203# ------------------------------------------------------------------------- 204 205# Try and load a compiled extension to help. 206namespace eval ::uuid { 207 foreach e {critcl} { if {[LoadAccelerator $e]} { break } } 208} 209 210package provide uuid $::uuid::version 211 212# ------------------------------------------------------------------------- 213# Local variables: 214# mode: tcl 215# indent-tabs-mode: nil 216# End: 217