Update Unicode docs
[factor/jcg.git] / basis / uuid / uuid.factor
blob337ea22df5b9694318db51366a480cd319a8d18a
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 io.binary ;
8 IN: uuid 
10 <PRIVATE
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 ]
20     tri ;
22 : (hardware) ( -- address ) 
23     ! Choose a random 48-bit number with eighth bit 
24     ! set to 1 (as recommended in RFC 4122)
25     48 random-bits HEX: 010000000000 bitor ;
27 : (clock) ( -- clockseq ) 
28     ! Choose a random 14-bit number
29     14 random-bits ;
31 : <uuid> ( address clockseq time_high time_mid time_low -- n )
32     96 shift 
33     [ 80 shift ] dip bitor 
34     [ 64 shift ] dip bitor
35     [ 48 shift ] dip bitor
36     bitor ;
38 : (version) ( n version -- n' )
39     [
40         HEX: c000 48 shift bitnot bitand 
41         HEX: 8000 48 shift bitor 
42         HEX: f000 64 shift bitnot bitand
43     ] dip 76 shift bitor ;
45 : uuid>string ( n -- string )
46     >hex 32 CHAR: 0 pad-left 
47     [ CHAR: - 20 ] dip insert-nth
48     [ CHAR: - 16 ] dip insert-nth 
49     [ CHAR: - 12 ] dip insert-nth 
50     [ CHAR: - 8 ] dip insert-nth ;
52 : string>uuid ( string -- n )
53     [ CHAR: - = not ] filter 16 base> ;
55 : uuid>byte-array ( n -- byte-array ) 
56     16 >be ;
58 PRIVATE>
60 : uuid-parse ( string -- byte-array ) 
61     string>uuid uuid>byte-array ;
63 : uuid-unparse ( byte-array -- string ) 
64     be> uuid>string ;
66 : uuid1 ( -- string )
67     (hardware) (clock) (timestamp) <uuid> 
68     1 (version) uuid>string ;
70 : uuid3 ( namespace name -- string )
71     [ uuid-parse ] dip append 
72     md5 checksum-bytes 16 short head be> 
73     3 (version) uuid>string ;
75 : uuid4 ( -- string )
76     128 random-bits 
77     4 (version) uuid>string ;
79 : uuid5 ( namespace name -- string )
80     [ uuid-parse ] dip append 
81     sha1 checksum-bytes 16 short head be> 
82     5 (version) uuid>string ;
84 CONSTANT: NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
85 CONSTANT: NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
86 CONSTANT: NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
87 CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"