basis/uuid/uuid.factor

   1 ! Copyright (C) 2008 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: byte-arrays calendar checksums checksums.md5
   4 checksums.sha io.binary kernel math math.parser math.ranges
   5 random sequences strings system unicode ;
   6 IN: uuid
   7
   8 <PRIVATE
   9
  10 : (timestamp) ( -- time_high time_mid time_low )
  11     ! 0x01b21dd213814000L is the number of 100-ns intervals
  12     ! between the UUID epoch 1582-10-15 00:00:00 and the
  13     ! Unix epoch 1970-01-01 00:00:00.
  14     gmt timestamp>micros 10 * 0x01b21dd213814000 +
  15     [ -48 shift 0x0fff bitand ]
  16     [ -32 shift 0xffff bitand ]
  17     [ 0xffffffff bitand ]
  18     tri ;
  19
  20 : (hardware) ( -- address )
  21     ! Choose a random 48-bit number with eighth bit
  22     ! set to 1 (as recommended in RFC 4122)
  23     48 random-bits 0x010000000000 bitor ;
  24
  25 : (clock) ( -- clockseq )
  26     ! Choose a random 14-bit number
  27     14 random-bits ;
  28
  29 : <uuid> ( address clockseq time_high time_mid time_low -- n )
  30     96 shift
  31     [ 80 shift ] dip bitor
  32     [ 64 shift ] dip bitor
  33     [ 48 shift ] dip bitor
  34     bitor ;
  35
  36 : (version) ( n version -- n' )
  37     [
  38         0xc000 48 shift bitnot bitand
  39         0x8000 48 shift bitor
  40         0xf000 64 shift bitnot bitand
  41     ] dip 76 shift bitor ;
  42
  43 : uuid>string ( n -- string )
  44     >hex 32 CHAR: 0 pad-head
  45     [ CHAR: - 20 ] dip insert-nth
  46     [ CHAR: - 16 ] dip insert-nth
  47     [ CHAR: - 12 ] dip insert-nth
  48     [ CHAR: - 8 ] dip insert-nth ;
  49
  50 : string>uuid ( string -- n )
  51     [ CHAR: - = ] reject hex> ;
  52
  53 PRIVATE>
  54
  55 : uuid-parse ( string -- byte-array )
  56     string>uuid 16 >be ;
  57
  58 : uuid-unparse ( byte-array -- string )
  59     be> uuid>string ;
  60
  61 : uuid1 ( -- string )
  62     (hardware) (clock) (timestamp) <uuid>
  63     1 (version) uuid>string ;
  64
  65 : uuid3 ( namespace name -- string )
  66     [ uuid-parse ] dip append
  67     md5 checksum-bytes 16 short head be>
  68     3 (version) uuid>string ;
  69
  70 : uuid4 ( -- string )
  71     128 random-bits
  72     4 (version) uuid>string ;
  73
  74 : uuid5 ( namespace name -- string )
  75     [ uuid-parse ] dip append
  76     sha1 checksum-bytes 16 short head be>
  77     5 (version) uuid>string ;
  78
  79 CONSTANT: NAMESPACE_DNS  "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
  80 CONSTANT: NAMESPACE_URL  "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
  81 CONSTANT: NAMESPACE_OID  "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
  82 CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"