cbor: support read/write of simple values and tagged items.

Fix issue with long array lengths.

diff --git a/extra/cbor/cbor-tests.factor b/extra/cbor/cbor-tests.factor
index 799890015fb0a151ee88200aea3b779cb07b9af3..6f39b7c41b1b4a8c24fee82ee806dd68bfb08f18 100644 (file)
--- a/extra/cbor/cbor-tests.factor
+++ b/extra/cbor/cbor-tests.factor
@@ -53,15 +53,15 @@ tools.test ;
 { t } [ B{ 0xf5 } cbor> ] unit-test
 { +cbor-nil+ } [ B{ 0xf6 } cbor> ] unit-test
 { +cbor-undefined+ } [ B{ 0xf7 } cbor> ] unit-test
-{ { "simple" 16 } } [ B{ 0xf0 } cbor> ] unit-test
-{ { "simple" 24 } } [ B{ 0xf8 0x18 } cbor> ] unit-test
-{ { "simple" 255 } } [ B{ 0xf8 0xff } cbor> ] unit-test
-{ { 0 "2013-03-21T20:04:00Z" } } [ "c074323031332d30332d32315432303a30343a30305a" hex-string>bytes cbor> ] unit-test
-{ { 1 1363896240 } } [ "c11a514b67b0" hex-string>bytes cbor> ] unit-test
-{ { 1 1363896240.5 } } [ "c1fb41d452d9ec200000" hex-string>bytes cbor> ] unit-test
-{ { 23 B{ 0x01 0x02 0x03 0x04 } } } [ "d74401020304" hex-string>bytes cbor> ] unit-test
-{ { 24 B{ 0x64 0x49 0x45 0x54 0x46 } } } [ "d818456449455446" hex-string>bytes cbor> ] unit-test
-{ { 32 "http://www.example.com" } } [ "d82076687474703a2f2f7777772e6578616d706c652e636f6d" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-simple f 16 } } [ B{ 0xf0 } cbor> ] unit-test
+{ T{ cbor-simple f 24 } } [ B{ 0xf8 0x18 } cbor> ] unit-test
+{ T{ cbor-simple f 255 } } [ B{ 0xf8 0xff } cbor> ] unit-test
+{ T{ cbor-tagged f 0 "2013-03-21T20:04:00Z" } } [ "c074323031332d30332d32315432303a30343a30305a" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-tagged f 1 1363896240 } } [ "c11a514b67b0" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-tagged f 1 1363896240.5 } } [ "c1fb41d452d9ec200000" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-tagged f 23 B{ 0x01 0x02 0x03 0x04 } } } [ "d74401020304" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-tagged f 24 B{ 0x64 0x49 0x45 0x54 0x46 } } } [ "d818456449455446" hex-string>bytes cbor> ] unit-test
+{ T{ cbor-tagged f 32 "http://www.example.com" } } [ "d82076687474703a2f2f7777772e6578616d706c652e636f6d" hex-string>bytes cbor> ] unit-test
 { B{ } } [ B{ 0x40 } cbor> ] unit-test
 { B{ 1 2 3 4 } } [ B{ 0x44 0x01 0x02 0x03 0x04 } cbor> ] unit-test
 { "" } [ B{ 0x60 } cbor> ] unit-test

diff --git a/extra/cbor/cbor.factor b/extra/cbor/cbor.factor
index 9bda61d35cc2f95d8dc13aea12abff743170681e..dad8a2535e1c9ecb681a35794d10399cdfe0bcac 100644 (file)
--- a/extra/cbor/cbor.factor
+++ b/extra/cbor/cbor.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2019 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: arrays assocs byte-arrays combinators io io.binary
-io.encodings.binary io.encodings.string io.encodings.utf8
-io.streams.byte-array io.streams.string kernel math
-math.bitwise math.floats.half sequences strings ;
+USING: accessors arrays assocs byte-arrays combinators io
+io.binary io.encodings.binary io.encodings.string
+io.encodings.utf8 io.streams.byte-array io.streams.string kernel
+math math.bitwise math.floats.half sequences strings ;
 
 IN: cbor
 
@@ -18,6 +18,10 @@ SINGLETON: +cbor-break+
 
 SINGLETON: +cbor-indefinite+
 
+TUPLE: cbor-tagged tag item ;
+
+TUPLE: cbor-simple value ;
+
 <PRIVATE
 
 : read-unsigned ( info -- n )
@@ -57,16 +61,16 @@ SINGLETON: +cbor-indefinite+
     ] if ;
 
 : read-tagged ( info -- tagged )
-    read-unsigned read-cbor 2array ;
+    read-unsigned read-cbor cbor-tagged boa ;
 
 : read-float ( info -- float )
-    dup 20 < [ "simple" swap 2array ] [
+    dup 20 < [ cbor-simple boa ] [
         {
             { 20 [ f ] }
             { 21 [ t ] }
             { 22 [ +cbor-nil+ ] }
             { 23 [ +cbor-undefined+ ] }
-            { 24 [ read1 "simple" swap 2array ] }
+            { 24 [ read1 cbor-simple boa ] }
             { 25 [ 2 read be> bits>half ] }
             { 26 [ 4 read be> bits>float ] }
             { 27 [ 8 read be> bits>double ] }
@@ -115,24 +119,36 @@ M: integer write-cbor
 
 M: float write-cbor 0xfb write1 double>bits 8 >be write ;
 
-: write-length ( type n -- )
-    [ 5 shift ] dip {
-        { [ dup 24 < ] [ bitor write1 ] }
-        { [ dup 0xff <= ] [ 24 bitor write1 write1 ] }
-        { [ dup 0xffff <= ] [ 25 bitor write1 2 >be write ] }
-        { [ dup 0xffffffff <= ] [ 26 bitor write1 4 >be write ] }
-        { [ dup 0xffffffffffffffff <= ] [ 27 bitor write1 8 >be write ] }
+: write-length ( n type -- )
+    5 shift {
+        { [ over 24 < ] [ bitor write1 ] }
+        { [ over 0xff <= ] [ 24 bitor write1 write1 ] }
+        { [ over 0xffff <= ] [ 25 bitor write1 2 >be write ] }
+        { [ over 0xffffffff <= ] [ 26 bitor write1 4 >be write ] }
+        { [ over 0xffffffffffffffff <= ] [ 27 bitor write1 8 >be write ] }
     } cond ;
 
-M: byte-array write-cbor 2 over length write-length write ;
+M: byte-array write-cbor dup length 2 write-length write ;
 
-M: string write-cbor 3 over length write-length utf8 encode write ;
+M: string write-cbor dup length 3 write-length utf8 encode write ;
 
 M: sequence write-cbor
-    4 over length write-length [ write-cbor ] each ;
+    dup length 4 write-length [ write-cbor ] each ;
 
 M: assoc write-cbor
-    5 over length write-length [ [ write-cbor ] bi@ ] assoc-each ;
+    dup length 5 write-length [ [ write-cbor ] bi@ ] assoc-each ;
+
+: write-byte ( n type -- )
+    5 shift {
+        { [ over 24 < ] [ bitor write1 ] }
+        { [ over 0xff <= ] [ 24 bitor write1 write1 ] }
+    } cond ;
+
+M: cbor-tagged write-cbor
+    dup tag>> 6 write-byte item>> write-cbor ;
+
+M: cbor-simple write-cbor
+    value>> 7 write-byte ;
 
 PRIVATE>