diff --git a/extra/uuid/authors.txt b/extra/uuid/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/uuid/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/uuid/summary.txt b/extra/uuid/summary.txt new file mode 100644 index 0000000000..ba555627a8 --- /dev/null +++ b/extra/uuid/summary.txt @@ -0,0 +1 @@ +Generates UUID's. diff --git a/extra/uuid/uuid-docs.factor b/extra/uuid/uuid-docs.factor new file mode 100644 index 0000000000..e23901171b --- /dev/null +++ b/extra/uuid/uuid-docs.factor @@ -0,0 +1,29 @@ + +USING: help.syntax help.markup kernel prettyprint sequences strings ; + +IN: uuid + +HELP: uuid1 +{ $description + "Generates a UUID (version 1) from the host ID, sequence number, " + "and current time." +} ; + +HELP: uuid3 +{ $description + "Generates a UUID (version 3) from the MD5 hash of a namespace " + "UUID and a name." +} ; + +HELP: uuid4 +{ $description + "Generates a UUID (version 4) from random bits." +} ; + +HELP: uuid5 +{ $description + "Generates a UUID (version 5) from the SHA-1 hash of a namespace " + "UUID and a name." +} ; + + diff --git a/extra/uuid/uuid-tests.factor b/extra/uuid/uuid-tests.factor new file mode 100644 index 0000000000..090f525532 --- /dev/null +++ b/extra/uuid/uuid-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: kernel uuid uuid.private tools.test ; + +IN: uuid.tests + +[ t ] [ NAMESPACE_URL [ string>uuid uuid>string ] keep = ] unit-test +[ t ] [ NAMESPACE_URL string>uuid [ uuid>byte-array byte-array>uuid ] keep = ] unit-test + + diff --git a/extra/uuid/uuid.factor b/extra/uuid/uuid.factor new file mode 100644 index 0000000000..585bcdcb98 --- /dev/null +++ b/extra/uuid/uuid.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2008 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: alien.syntax alien.c-types byte-arrays +checksums checksums.md5 checksums.sha1 kernel +math math.parser math.ranges random unicode.case +sequences strings system ; + +IN: uuid + + ( address clockseq time_high time_mid time_low -- n ) + 96 shift + [ 80 shift ] dip bitor + [ 64 shift ] dip bitor + [ 48 shift ] dip bitor + bitor ; + +: (version) ( n version -- n' ) + [ HEX: c000 48 shift bitnot bitand + HEX: 8000 48 shift bitor + HEX: f000 64 shift bitnot bitand + ] dip 76 shift bitor ; + +: uuid>string ( n -- string ) + >hex 32 CHAR: 0 pad-left + CHAR: - 20 rot insert-nth + CHAR: - 16 rot insert-nth + CHAR: - 12 rot insert-nth + CHAR: - 8 rot insert-nth ; + +: string>uuid ( string -- n ) + [ CHAR: - = not ] filter 16 base> ; + +: uuid>byte-array ( n -- byte-array ) + 16 swap 0 15 1 + [ dup 8 * neg [ swap dup ] dip + shift HEX: ff bitand rot roll + [ set-nth ] keep swap + ] each drop reverse ; + +: byte-array>uuid ( byte-array -- n ) + [ >hex 2 CHAR: 0 pad-left ] { } map-as "" join 16 base> ; + +PRIVATE> + +: uuid-parse ( string -- byte-array ) + string>uuid uuid>byte-array ; + +: uuid-unparse ( byte-array -- string ) + byte-array>uuid uuid>string ; + +: uuid1 ( -- string ) + (hardware) (clock) (timestamp) + 1 (version) uuid>string ; + +: uuid3 ( namespace name -- string ) + [ uuid-parse ] dip >byte-array append + md5 checksum-bytes 16 short head byte-array>uuid + 3 (version) uuid>string ; + +: uuid4 ( -- string ) + 128 random-bits + 4 (version) uuid>string ; + +: uuid5 ( namespace name -- string ) + [ uuid-parse ] dip >byte-array append + sha1 checksum-bytes 16 short head byte-array>uuid + 5 (version) uuid>string ; + + +: NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8" ; inline +: NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8" ; inline +: NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8" ; inline +: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8" ; inline + +