steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up UUID a bit and fix help lint

db4
Slava Pestov 2008-12-22 01:22:05 -06:00
parent c6ac320515
commit 3332727227
2 changed files with 25 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/uuid/uuid-docs.factor
View File

@ -4,23 +4,27 @@ USING: help.syntax help.markup kernel prettyprint sequences strings ;
IN: uuid IN: uuid
HELP: uuid1 HELP: uuid1
{ $values { "string" "a UUID string" } }
{ $description { $description
"Generates a UUID (version 1) from the host ID, sequence number, " "Generates a UUID (version 1) from the host ID, sequence number, "
"and current time." "and current time."
} ; } ;
HELP: uuid3 HELP: uuid3
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
{ $description { $description
"Generates a UUID (version 3) from the MD5 hash of a namespace " "Generates a UUID (version 3) from the MD5 hash of a namespace "
"UUID and a name." "UUID and a name."
} ; } ;
HELP: uuid4 HELP: uuid4
{ $values { "string" "a UUID string" } }
{ $description { $description
"Generates a UUID (version 4) from random bits." "Generates a UUID (version 4) from random bits."
} ; } ;
HELP: uuid5 HELP: uuid5
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
{ $description { $description
"Generates a UUID (version 5) from the SHA-1 hash of a namespace " "Generates a UUID (version 5) from the SHA-1 hash of a namespace "
"UUID and a name." "UUID and a name."
@ -28,12 +32,10 @@ HELP: uuid5
ARTICLE: "uuid" "UUID (Universally Unique Identifier)" ARTICLE: "uuid" "UUID (Universally Unique Identifier)"
"The " { $vocab-link "uuid" } " vocabulary is used to generate UUID's. " "The " { $vocab-link "uuid" } " vocabulary is used to generate UUIDs. "
"The words uuid1, uuid3, uuid4, uuid5 can be used to generate version " "The below words can be used to generate version 1, 3, 4, and 5 UUIDs as specified in RFC 4122."
"1, 3, 4, and 5 UUIDs as specified in RFC 4122.\n" $nl
"\n" "If all you want is a unique ID, you should probably call " { $link uuid1 } " or " { $link uuid4 } "."
"If all you want is a unique ID, you should probably call uuid1 or uuid4."
"\n"
{ $subsection uuid1 } { $subsection uuid1 }
{ $subsection uuid3 } { $subsection uuid3 }
{ $subsection uuid4 } { $subsection uuid4 }

35
basis/uuid/uuid.factor
View File

@ -3,7 +3,7 @@
USING: byte-arrays checksums checksums.md5 checksums.sha1 USING: byte-arrays checksums checksums.md5 checksums.sha1
kernel math math.parser math.ranges random unicode.case kernel math math.parser math.ranges random unicode.case
sequences strings system ; sequences strings system io.binary ;
IN: uuid IN: uuid
@ -16,7 +16,8 @@ IN: uuid
micros 10 * HEX: 01b21dd213814000 + micros 10 * HEX: 01b21dd213814000 +
[ -48 shift HEX: 0fff bitand ] [ -48 shift HEX: 0fff bitand ]
[ -32 shift HEX: ffff bitand ] [ -32 shift HEX: ffff bitand ]
[ HEX: ffffffff bitand ] tri ; [ HEX: ffffffff bitand ]
tri ;
: (hardware) ( -- address ) : (hardware) ( -- address )
! Choose a random 48-bit number with eighth bit ! Choose a random 48-bit number with eighth bit
@ -35,7 +36,8 @@ IN: uuid
bitor ; bitor ;
: (version) ( n version -- n' ) : (version) ( n version -- n' )
[ HEX: c000 48 shift bitnot bitand [
HEX: c000 48 shift bitnot bitand
HEX: 8000 48 shift bitor HEX: 8000 48 shift bitor
HEX: f000 64 shift bitnot bitand HEX: f000 64 shift bitnot bitand
] dip 76 shift bitor ; ] dip 76 shift bitor ;
@ -51,13 +53,7 @@ IN: uuid
[ CHAR: - = not ] filter 16 base> ; [ CHAR: - = not ] filter 16 base> ;
: uuid>byte-array ( n -- byte-array ) : uuid>byte-array ( n -- byte-array )
16 <byte-array> 15 -1 [a,b) [ 16 >be ;
[ dup HEX: ff bitand ] 2dip swap
[ set-nth -8 shift ] keep
] each nip ;
: byte-array>uuid ( byte-array -- n )
0 swap [ [ 8 shift ] dip + ] each ;
PRIVATE> PRIVATE>
@ -65,15 +61,15 @@ PRIVATE>
string>uuid uuid>byte-array ; string>uuid uuid>byte-array ;
: uuid-unparse ( byte-array -- string ) : uuid-unparse ( byte-array -- string )
byte-array>uuid uuid>string ; be> uuid>string ;
: uuid1 ( -- string ) : uuid1 ( -- string )
(hardware) (clock) (timestamp) <uuid> (hardware) (clock) (timestamp) <uuid>
1 (version) uuid>string ; 1 (version) uuid>string ;
: uuid3 ( namespace name -- string ) : uuid3 ( namespace name -- string )
[ uuid-parse ] dip >byte-array append [ uuid-parse ] dip append
md5 checksum-bytes 16 short head byte-array>uuid md5 checksum-bytes 16 short head be>
3 (version) uuid>string ; 3 (version) uuid>string ;
: uuid4 ( -- string ) : uuid4 ( -- string )
@ -81,14 +77,13 @@ PRIVATE>
4 (version) uuid>string ; 4 (version) uuid>string ;
: uuid5 ( namespace name -- string ) : uuid5 ( namespace name -- string )
[ uuid-parse ] dip >byte-array append [ uuid-parse ] dip append
sha1 checksum-bytes 16 short head byte-array>uuid sha1 checksum-bytes 16 short head be>
5 (version) uuid>string ; 5 (version) uuid>string ;
CONSTANT: NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
: NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8" ; inline CONSTANT: NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
: NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8" ; inline CONSTANT: NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
: NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8" ; inline CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"
: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8" ; inline