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