tnetstrings: vocab to parse "tagged netstrings".

diff --git a/extra/tnetstrings/authors.txt b/extra/tnetstrings/authors.txt
new file mode 100644 (file)
index 0000000..e091bb8
--- /dev/null
+++ b/extra/tnetstrings/authors.txt
@@ -0,0 +1 @@
+John Benediktsson

diff --git a/extra/tnetstrings/summary.txt b/extra/tnetstrings/summary.txt
new file mode 100644 (file)
index 0000000..4db1c3f
--- /dev/null
+++ b/extra/tnetstrings/summary.txt
@@ -0,0 +1 @@
+Reader and writer for "tagged netstrings"

diff --git a/extra/tnetstrings/tnetstrings-tests.factor b/extra/tnetstrings/tnetstrings-tests.factor
new file mode 100644 (file)
index 0000000..f6d7329
--- /dev/null
+++ b/extra/tnetstrings/tnetstrings-tests.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel tnetstrings sequences tools.test ;
+
+[ t ] [
+    {
+        { H{ } "0:}" }
+        { { } "0:]" }
+        { "" "0:\"" }
+        { t "4:true!" }
+        { f "5:false!" }
+        { 12345 "5:12345#" }
+        { "this is cool" "12:this is cool\"" }
+        {
+            H{ { "hello" { 12345678901 "this" } } }
+            "34:5:hello\"22:11:12345678901#4:this\"]}"
+        }
+        {
+            { 12345 67890 "xxxxx" }
+            "24:5:12345#5:67890#5:xxxxx\"]"
+        }
+    } [
+        first2 [ tnetstring> = ] [ swap >tnetstring = ] 2bi and
+    ] all?
+] unit-test

diff --git a/extra/tnetstrings/tnetstrings.factor b/extra/tnetstrings/tnetstrings.factor
new file mode 100644 (file)
index 0000000..d9b9f1c
--- /dev/null
+++ b/extra/tnetstrings/tnetstrings.factor
@@ -0,0 +1,98 @@
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs combinators formatting hashtables kernel
+math math.parser sequences splitting strings ;
+
+IN: tnetstrings
+
+<PRIVATE
+
+: parse-payload ( data -- remain payload payload-type )
+    ":" split1 swap string>number cut unclip swapd ;
+
+DEFER: parse-tnetstring
+
+: parse-list ( data -- value )
+    [ { } ] [
+        [ dup empty? not ] [ parse-tnetstring ] produce nip
+    ] if-empty ;
+
+: parse-pair ( data -- extra value key )
+    parse-tnetstring [
+        [ "Unbalanced dictionary store" throw ] when-empty
+        parse-tnetstring
+        [ "Invalid value, null not allowed" throw ] unless*
+    ] dip ;
+
+: parse-dict ( data -- value )
+    [ H{ } ] [
+        [ dup empty? not ] [ parse-pair swap 2array ] produce
+        nip >hashtable
+    ] if-empty ;
+
+: parse-bool ( data -- ? )
+    {
+        { "true" [ t ] }
+        { "false" [ f ] }
+        [ "Invalid bool: %s" sprintf throw ]
+    } case ;
+
+: parse-null ( data -- f )
+    [ f ] [ drop "Payload must be 0 length" throw ] if-empty ;
+
+: parse-tnetstring ( data -- remain value )
+    parse-payload {
+        { CHAR: # [ string>number ] }
+        { CHAR: " [ ] }
+        { CHAR: } [ parse-dict ] }
+        { CHAR: ] [ parse-list ] }
+        { CHAR: ! [ parse-bool ] }
+        { CHAR: ~ [ parse-null ] }
+        { CHAR: , [ ] }
+        [ "Invalid payload type: %c" sprintf throw ]
+    } case ;
+
+PRIVATE>
+
+: tnetstring> ( string -- value )
+    parse-tnetstring swap [
+        "Had trailing junk: %s" sprintf throw
+    ] unless-empty ;
+
+<PRIVATE
+
+DEFER: dump-tnetstring
+
+: dump ( string type -- string )
+    [ [ length ] keep ] dip "%d:%s%s" sprintf ;
+
+: dump-number ( data -- string ) number>string "#" dump ;
+
+: dump-string ( data -- string ) "\"" dump ;
+
+: dump-list ( data -- string )
+    [ dump-tnetstring ] map "" concat-as "]" dump ;
+
+: dump-dict ( data -- string )
+    >alist [ first2 [ dump-tnetstring ] bi@ append ] map
+    "" concat-as "}" dump ;
+
+: dump-bool ( ? -- string )
+    "4:true!" "5:false!" ? ;
+
+: dump-tnetstring ( data -- string )
+    {
+        { [ dup boolean?  ] [ dump-bool ] }
+        { [ dup number?   ] [ dump-number ] }
+        { [ dup string?   ] [ dump-string ] }
+        { [ dup sequence? ] [ dump-list ] }
+        { [ dup assoc?    ] [ dump-dict ] }
+        [ "Can't serialize object" throw ]
+    } cond ;
+
+PRIVATE>
+
+: >tnetstring ( value -- string )
+    dump-tnetstring ;
+