1 ! Copyright (C) 2008 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: byte-arrays checksums checksums.md5 checksums.sha1
5 kernel math math.parser math.ranges random unicode.case
6 sequences strings system ;
12 : (timestamp) ( -- time_high time_mid time_low )
13 ! 0x01b21dd213814000L is the number of 100-ns intervals
14 ! between the UUID epoch 1582-10-15 00:00:00 and the
15 ! Unix epoch 1970-01-01 00:00:00.
16 micros 10 * HEX: 01b21dd213814000 +
17 [ -48 shift HEX: 0fff bitand ]
18 [ -32 shift HEX: ffff bitand ]
19 [ HEX: ffffffff bitand ] tri ;
21 : (hardware) ( -- address )
22 ! Choose a random 48-bit number with eighth bit
23 ! set to 1 (as recommended in RFC 4122)
24 48 random-bits HEX: 010000000000 bitor ;
26 : (clock) ( -- clockseq )
27 ! Choose a random 14-bit number
30 : <uuid> ( address clockseq time_high time_mid time_low -- n )
32 [ 80 shift ] dip bitor
33 [ 64 shift ] dip bitor
34 [ 48 shift ] dip bitor
37 : (version) ( n version -- n' )
38 [ HEX: c000 48 shift bitnot bitand
39 HEX: 8000 48 shift bitor
40 HEX: f000 64 shift bitnot bitand
41 ] dip 76 shift bitor ;
43 : uuid>string ( n -- string )
44 >hex 32 CHAR: 0 pad-left
45 [ CHAR: - 20 ] dip insert-nth
46 [ CHAR: - 16 ] dip insert-nth
47 [ CHAR: - 12 ] dip insert-nth
48 [ CHAR: - 8 ] dip insert-nth ;
50 : string>uuid ( string -- n )
51 [ CHAR: - = not ] filter 16 base> ;
53 : uuid>byte-array ( n -- byte-array )
54 16 <byte-array> 15 -1 [a,b) [
55 [ dup HEX: ff bitand ] 2dip swap
56 [ set-nth -8 shift ] keep
59 : byte-array>uuid ( byte-array -- n )
60 0 swap [ [ 8 shift ] dip + ] each ;
64 : uuid-parse ( string -- byte-array )
65 string>uuid uuid>byte-array ;
67 : uuid-unparse ( byte-array -- string )
68 byte-array>uuid uuid>string ;
71 (hardware) (clock) (timestamp) <uuid>
72 1 (version) uuid>string ;
74 : uuid3 ( namespace name -- string )
75 [ uuid-parse ] dip >byte-array append
76 md5 checksum-bytes 16 short head byte-array>uuid
77 3 (version) uuid>string ;
81 4 (version) uuid>string ;
83 : uuid5 ( namespace name -- string )
84 [ uuid-parse ] dip >byte-array append
85 sha1 checksum-bytes 16 short head byte-array>uuid
86 5 (version) uuid>string ;
89 : NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8" ; inline
90 : NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8" ; inline
91 : NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8" ; inline
92 : NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8" ; inline