Scott Nichols I recommend adding this C++ code to the WinUtils library for creating unique global identifiers (GUIDs). I had a customer that required a GUID be generated with each SOAP transaction so I wrote the Tcl method call in C++ (below) for this, and thought it might be a good candidate for the WinUtils library. The C++ code below is using two dependent libs: tclstub83.lib and rpcrt4.lib. Rpcrt4.lib is part of the Windows OS, and should come with Visual Studio or .net. The source code is so short that I went ahead and posted both C++ source files below. The sources can be compiled into a Tcl library extension (DLL) for Windows platforms.
TclGUID.h:
/*
* TclGUID.h v1.0 12-11-2003 Scott Nichols
*
*/
/* TCL Function prototype declarations */
#ifndef TclGUID_H
#define TclGUID_H
#define USE_NON_CONST
#define TCL_USE_STUBS
#include <tcl.h>
#include "StdAfx.h"
extern "C"
{
__declspec(dllexport) int Tclguid_Init(Tcl_Interp* interp);
}
static int GetGUID_ObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
#endif
TclGUID.cpp:
/* * TclGUID.cpp, v1.0 12/11/2003, Scott J. Nichols * [email protected] * * The GetGUID Tcl method returns a 128 bit unique identifier * to the Tcl interpreter. Microsoft calls it a globally unique identifier (GUID). * The application I am using it for is the transaction ID for SOAP messages. This was a customer * requirement of mine. * */ #include "TclGUID.h" static int GetGUID_ObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) { GUID guid; // create random GUID guid = GUID_NULL; ::CoCreateGuid(&guid); if (guid == GUID_NULL) { Tcl_Obj *obj_result = Tcl_NewStringObj((const char *)"Unable to create GUID.", strlen((const char *) "Unable to create GUID.")); Tcl_SetObjResult(interp,obj_result); return TCL_ERROR; } else { BYTE * str; UuidToString((UUID*)&guid, &str); Tcl_UtfToUpper((char *)str); // Return the GUID to the Tcl Interpreter Tcl_Obj *obj_result = Tcl_NewStringObj((const char *)str, strlen((const char *)str)); Tcl_SetObjResult(interp,obj_result); RpcStringFree(&str); return TCL_OK; } } /* Main Routine in the TCL Extension DLL */ int Tclguid_Init(Tcl_Interp *interp) { #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 // Does the TCL interpreter support version 8.3 of TCL? if (Tcl_InitStubs(interp,"8.3",0) == NULL) return TCL_ERROR; #endif Tcl_CreateObjCommand(interp, "GetGUID", GetGUID_ObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); return (Tcl_PkgProvide(interp,"TclGUID","1.0") == TCL_ERROR ? TCL_ERROR : TCL_OK); }
Each time the GetGUID method is called from Tcl a different 128 bit number is returned that looks similar to this: DE4ED408-5200-46E5-8AD1-EEF7351A7C07
PT: Here is a pure-Tcl uuid generator. I can't vouch for the uniqueness, but it shouldn't be too bad.
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <[email protected]> # # http://hegel.ittc.ukans.edu/topics/internet/internet-drafts/draft-l/draft-leach-uuids-guids-01.txt # # # UUIDs are 128 bit values that attempt to be unique in time and space. # # uuid: scheme: # http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html # # Usage: uuid::uuid generate # uuid::uuid compare $idA $idB namespace eval uuid { variable version 1.0.0 variable uid if {![info exists uid]} { set uid 1 } proc S {a b} {set a} } proc ::uuid::generate {} { package require md5 variable uid set tok [md5::MD5Init] md5::MD5Update $tok [clock seconds]; # timestamp md5::MD5Update $tok [clock clicks]; # system incrementing counter md5::MD5Update $tok [incr uid]; # package incrementing counter md5::MD5Update $tok [info hostname]; # spatial unique id (poor) md5::MD5Update $tok [array get ::tcl_platform] catch { set s [socket -server void -myaddr [info hostname] 0] S [fconfigure $s -sockname] [close $s] } r md5::MD5Update $tok $r if {[package provide Tk] != {}} { md5::MD5Update $tok [winfo pointerxy .] md5::MD5Update $tok [winfo id .] } set r [md5::MD5Final $tok] binary scan $r c* r # 3.4: set uuid versioning fields lset r 8 [expr {([lindex $r 8] & 0x7F) | 0x40}] lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] return [binary format c* $r] } proc ::uuid::tostring {uuid} { set s [md5::Hex $uuid] 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 -]] } proc ::uuid::fromstring {uuid} { return [binary format H* [string map {- {}} $uuid]] } proc ::uuid::compare {left right} { set l [fromstring $left] set r [fromstring $right] return [string compare $l $r] } # uuid generate -> string rep of a new uuid # uuid equal uuid1 uuid2 # proc uuid::uuid {cmd args} { switch -exact -- $cmd { generate { return [tostring [generate]] } compare { if {[llength $args] != 2} { return -code error "wrong \# args:\ should be \"uuid compare uuid1 uuid2\"" } foreach {left right} $args {} return [compare $left $right] } default { return -code error "bad option \"$cmd\":\ must be generate or compare" } } } # ------------------------------------------------------------------------- package provide uuid $::uuid::version # -------------------------------------------------------------------------