--- /dev/null
+John Benediktsson
--- /dev/null
+USING: byte-arrays help.markup help.syntax io kernel sequences strings ;
+
+IN: cbor
+
+HELP: read-cbor
+{ $values { "obj" object } }
+{ $description "Decodes an object that was serialized in the CBOR format, reading from an " { $link input-stream } "." } ;
+
+HELP: write-cbor
+{ $values { "obj" object } }
+{ $description "Encodes an object into the CBOR format, writing to an " { $link output-stream } "." } ;
+
+HELP: cbor>
+{ $values { "seq" sequence } { "obj" object } }
+{ $description "Decodes an object from the CBOR format, represented as a " { $link byte-array } " or " { $link string } "." } ;
+
+HELP: >cbor
+{ $values { "obj" object } { "bytes" byte-array } }
+{ $description "Encodes an object into the CBOR format." } ;
+
+ARTICLE: "cbor" "Concise Binary Object Representation (CBOR)"
+"The Concise Binary Object Representation (CBOR) is defined in RFC 7049."
+$nl
+"Decoding support for the CBOR protocol:"
+{ $subsections
+ read-cbor
+ cbor>
+}
+"Encoding support for the CBOR protocol:"
+{ $subsections
+ write-cbor
+ >cbor
+} ;
+
+ABOUT: "cbor"
--- /dev/null
+USING: arrays assocs calendar cbor kernel literals locals math
+math.parser math.ranges tools.test urls ;
+
+{
+ { 0 "00" }
+ { 1 "01" }
+ { 10 "0a" }
+ { 23 "17" }
+ { 24 "1818" }
+ { 25 "1819" }
+ { 100 "1864" }
+ { 1000 "1903e8" }
+ { 1000000 "1a000f4240" }
+ { 1000000000000 "1b000000e8d4a51000" }
+ { 18446744073709551615 "1bffffffffffffffff" }
+ { 18446744073709551616 "c249010000000000000000" }
+ { -18446744073709551616 "3bffffffffffffffff" }
+ { -18446744073709551617 "c349010000000000000000" }
+ { -1 "20" }
+ { -10 "29" }
+ { -100 "3863" }
+ { -1000 "3903e7" }
+ { 0.0 "f90000" }
+ { -0.0 "f98000" }
+ { 1.0 "f93c00" }
+ { 1.1 "fb3ff199999999999a" }
+ { 1.5 "f93e00" }
+ { 65504.0 "f97bff" }
+ { 100000.0 "fa47c35000" }
+ { 3.4028234663852886e+38 "fa7f7fffff" }
+ { 1.0e+300 "fb7e37e43c8800759c" }
+ ! FIXME { 5.960464477539063e-8 "f90001" }
+ { 0.00006103515625 "f90400" }
+ { -4.0 "f9c400" }
+ { -4.1 "fbc010666666666666" }
+ { 1/0. "f97c00" }
+ { NAN: 8000000000000 "f97e00" }
+ { -1/0. "f9fc00" }
+ { 1/0. "fa7f800000" }
+ { NAN: 8000000000000 "fa7fc00000" }
+ { -1/0. "faff800000" }
+ { 1/0. "fb7ff0000000000000" }
+ { NAN: 8000000000000 "fb7ff8000000000000" }
+ { -1/0. "fbfff0000000000000" }
+ { f "f4" }
+ { t "f5" }
+ { +cbor-nil+ "f6" }
+ { +cbor-undefined+ "f7" }
+ { T{ cbor-simple f 16 } "f0" }
+ { T{ cbor-simple f 24 } "f818" }
+ { T{ cbor-simple f 255 } "f8ff" }
+ {
+ T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } }
+ "c074323031332d30332d32315432303a30343a30305a"
+ }
+ {
+ T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } }
+ "c11a514b67b0"
+ }
+ {
+ T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } { second 0.5 } }
+ "c1fb41d452d9ec200000"
+ }
+ { T{ cbor-tagged f 23 B{ 1 2 3 4 } } "d74401020304" }
+ { T{ cbor-tagged f 24 B{ 0x64 0x49 0x45 0x54 0x46 } } "d818456449455446" }
+ { URL" http://www.example.com" "d82076687474703a2f2f7777772e6578616d706c652e636f6d" }
+ { B{ } "40" }
+ { B{ 1 2 3 4 } "4401020304" }
+ { B{ 0xaa 0xbb 0xcc 0xdd 0xee 0xff 0x99 } "5F44aabbccdd43eeff99ff" }
+ { "" "60" }
+ { "a" "6161" }
+ { "IETF" "6449455446" }
+ { "\"\\" "62225c" }
+ { "\u0000fc" "62c3bc" }
+ { "\u006c34" "63e6b0b4" }
+ ! FIXME { "\u00d800\u00dd51" "64f0908591" }
+ { { } "80" }
+ { { 1 2 3 } "83010203" }
+ { { 1 { 2 3 } { 4 5 } } "8301820203820405" }
+ ${ 25 [1,b] >array "98190102030405060708090a0b0c0d0e0f101112131415161718181819" }
+ { { } "a0" }
+ { { { 1 2 } { 3 4 } } "a201020304" }
+ { { { "a" 1 } { "b" { 2 3 } } } "a26161016162820203" }
+ { { "a" { { "b" "c" } } } "826161a161626163" }
+ {
+ { { "a" "A" } { "b" "B" } { "c" "C" } { "d" "D" } { "e" "E" } }
+ "a56161614161626142616361436164614461656145"
+ }
+ { { 1 { 2 3 } { 4 5 } } "9f018202039f0405ffff" }
+ { { 1 { 2 3 } { 4 5 } } "9f01820203820405ff" }
+ { { 1 { 2 3 } { 4 5 } } "83018202039f0405ff" }
+ { { 1 { 2 3 } { 4 5 } } "83019f0203ff820405" }
+ ${ 25 [1,b] >array "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff" }
+ { { { "a" 1 } { "b" { 2 3 } } } "bf61610161629f0203ffff" }
+ { { "a" { { "b" "c" } } } "826161bf61626163ff" }
+ { { { "Fun" t } { "Amt" -2 } } "bf6346756ef563416d7421ff" }
+} [| value hex-string |
+
+ hex-string hex-string>bytes :> bytes
+
+ value fp-nan? [
+ { t t } [
+ bytes cbor> [ fp-nan? ] [ fp-nan-payload ] bi
+ value fp-nan-payload =
+ ] unit-test
+ ] [
+ { value } [ bytes cbor> ] unit-test
+ ] if
+
+] assoc-each
--- /dev/null
+! Copyright (C) 2019 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays assocs base64 byte-arrays calendar
+calendar.format calendar.parser 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 present sequences strings urls ;
+
+IN: cbor
+
+DEFER: read-cbor
+
+SINGLETON: +cbor-nil+
+
+SINGLETON: +cbor-undefined+
+
+SINGLETON: +cbor-break+
+
+SINGLETON: +cbor-indefinite+
+
+TUPLE: cbor-tagged tag item ;
+
+TUPLE: cbor-simple value ;
+
+<PRIVATE
+
+: read-unsigned ( info -- n )
+ dup 24 < [
+ {
+ { 24 [ read1 ] }
+ { 25 [ 2 read be> ] }
+ { 26 [ 4 read be> ] }
+ { 27 [ 8 read be> ] }
+ { 31 [ +cbor-indefinite+ ] }
+ } case
+ ] unless ;
+
+: read-bytestring ( info -- byte-array )
+ read-unsigned dup +cbor-indefinite+ = [
+ drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip concat
+ ] [
+ read [ B{ } ] unless*
+ ] if ;
+
+: read-textstring ( info -- string )
+ read-bytestring utf8 decode ;
+
+: read-array ( info -- array )
+ read-unsigned dup +cbor-indefinite+ = [
+ drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip
+ ] [
+ [ read-cbor ] replicate
+ ] if ;
+
+: read-map ( info -- alist )
+ read-unsigned dup +cbor-indefinite+ = [
+ drop [ read-cbor dup +cbor-break+ = not ]
+ [ read-cbor 2array ] produce nip
+ ] [
+ [ read-cbor read-cbor 2array ] replicate
+ ] if ;
+
+: read-tagged ( info -- tagged )
+ read-unsigned read-cbor swap {
+ { 0 [ rfc3339>timestamp ] }
+ { 1 [ unix-time>timestamp ] }
+ { 2 [ be> ] }
+ { 3 [ be> neg 1 - ] }
+ { 32 [ >url ] }
+ { 33 [ base64> ] }
+ [ swap cbor-tagged boa ]
+ } case ;
+
+: read-float ( info -- float )
+ dup 20 < [ cbor-simple boa ] [
+ {
+ { 20 [ f ] }
+ { 21 [ t ] }
+ { 22 [ +cbor-nil+ ] }
+ { 23 [ +cbor-undefined+ ] }
+ { 24 [ read1 cbor-simple boa ] }
+ { 25 [ 2 read be> bits>half ] }
+ { 26 [ 4 read be> bits>float ] }
+ { 27 [ 8 read be> bits>double ] }
+ { 31 [ +cbor-break+ ] }
+ } case
+ ] if ;
+
+PRIVATE>
+
+: read-cbor ( -- obj )
+ read1 [ 5 bits ] [ -5 shift 3 bits ] bi {
+ { 0 [ read-unsigned ] }
+ { 1 [ read-unsigned neg 1 - ] }
+ { 2 [ read-bytestring ] }
+ { 3 [ read-textstring ] }
+ { 4 [ read-array ] }
+ { 5 [ read-map ] }
+ { 6 [ read-tagged ] }
+ { 7 [ read-float ] }
+ } case ;
+
+GENERIC: write-cbor ( obj -- )
+
+<PRIVATE
+
+M: f write-cbor drop 0xf4 write1 ;
+
+M: t write-cbor drop 0xf5 write1 ;
+
+M: +cbor-nil+ write-cbor drop 0xf6 write1 ;
+
+M: +cbor-undefined+ write-cbor drop 0xf7 write1 ;
+
+: write-integer ( 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 ] }
+ [
+ -5 shift 2 + 0xc0 bitor write1
+ dup bit-length 8 /mod zero? [ 1 + ] unless
+ >be write-cbor
+ ]
+ } cond ;
+
+M: integer write-cbor
+ dup 0 >= [ 0 write-integer ] [ neg 1 - 1 write-integer ] if ;
+
+M: float write-cbor 0xfb write1 double>bits 8 >be write ;
+
+M: byte-array write-cbor dup length 2 write-integer write ;
+
+M: string write-cbor dup length 3 write-integer utf8 encode write ;
+
+M: sequence write-cbor
+ dup length 4 write-integer [ write-cbor ] each ;
+
+M: assoc write-cbor
+ dup length 5 write-integer [ [ write-cbor ] bi@ ] assoc-each ;
+
+M: timestamp write-cbor
+ 0 6 write-integer timestamp>rfc3339 write-cbor ;
+
+M: url write-cbor
+ 32 6 write-integer present write-cbor ;
+
+M: cbor-tagged write-cbor
+ dup tag>> 6 write-integer item>> write-cbor ;
+
+M: cbor-simple write-cbor
+ value>> 7 write-integer ;
+
+PRIVATE>
+
+GENERIC: cbor> ( seq -- obj )
+
+M: string cbor>
+ [ read-cbor ] with-string-reader ;
+
+M: byte-array cbor>
+ binary [ read-cbor ] with-byte-reader ;
+
+: >cbor ( obj -- bytes )
+ binary [ write-cbor ] with-byte-writer ;
--- /dev/null
+Support for Concise Binary Object Representation (CBOR)
--- /dev/null
+file formats
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: byte-arrays help.markup help.syntax io kernel sequences strings ;
+
+IN: msgpack
+
+HELP: read-msgpack
+{ $values { "obj" object } }
+{ $description "Decodes an object that was serialized in the MessagePack format, reading from an " { $link input-stream } "." } ;
+
+HELP: write-msgpack
+{ $values { "obj" object } }
+{ $description "Encodes an object into the MessagePack format, writing to an " { $link output-stream } "." } ;
+
+HELP: msgpack>
+{ $values { "seq" sequence } { "obj" object } }
+{ $description "Decodes an object from the MessagePack format, represented as a " { $link byte-array } " or " { $link string } "." } ;
+
+HELP: >msgpack
+{ $values { "obj" object } { "bytes" byte-array } }
+{ $description "Encodes an object into the MessagePack format." } ;
+
+ARTICLE: "msgpack" "MessagePack"
+"Decoding support for the MessagePack protocol:"
+{ $subsections
+ read-msgpack
+ msgpack>
+}
+"Encoding support for the MessagePack protocol:"
+{ $subsections
+ write-msgpack
+ >msgpack
+} ;
+
+ABOUT: "msgpack"
--- /dev/null
+USING: io.streams.string kernel math msgpack sequences
+tools.test ;
+
+{
+ {
+ +msgpack-nil+
+ f
+ t
+ -1
+ -31
+ 128
+ -1152921504606846976
+ 1.5
+ 1.23434536
+ "hello"
+ { 1 1234 123456789 }
+ H{ { 1 "hello" } { 2 "goodbye" } }
+ }
+} [
+
+ {
+ "\xc0"
+ "\xc2"
+ "\xc3"
+ "\xff"
+ "\xe1"
+ "\xcc\x80"
+ "\xd3\xf0\x00\x00\x00\x00\x00\x00\x00"
+ "\xcb?\xf8\x00\x00\x00\x00\x00\x00"
+ "\xcb?\xf3\xbf\xe0\xeb\x92\xb5\xa5"
+ "\xa5hello"
+ "\x93\x01\xcd\x04\xd2\xce\x07[\xcd\x15"
+ "\x82\x01\xa5hello\x02\xa7goodbye"
+ } [ msgpack> ] map
+] unit-test
+
+{ t } [
+ {
+ +msgpack-nil+
+ f
+ t
+ -1
+ -31
+ 128
+ -1152921504606846976
+ 1.5
+ 1.23434536
+ "hello"
+ { 1 1234 123456789 }
+ H{ { 1 "hello" } { 2 "goodbye" } }
+ } [ dup >msgpack msgpack> = ] all?
+] unit-test
+
+[ 64 2^ >msgpack ] [ cannot-convert? ] must-fail-with
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs byte-arrays combinators grouping hashtables
+io io.binary io.encodings io.encodings.binary
+io.encodings.string io.encodings.utf8 io.streams.byte-array
+io.streams.string kernel math math.bitwise math.order namespaces
+sequences strings ;
+
+IN: msgpack
+
+DEFER: read-msgpack
+
+<PRIVATE
+
+: read-array ( n -- obj )
+ [ read-msgpack ] replicate ;
+
+: read-map ( n -- obj )
+ 2 * read-array 2 group >hashtable ;
+
+: read-ext ( n -- obj )
+ read be> [ 1 read signed-be> ] dip read 2array ;
+
+PRIVATE>
+
+SINGLETON: +msgpack-nil+
+
+ERROR: unknown-format n ;
+
+: read-msgpack ( -- obj )
+ read1 {
+ { [ dup 0xc0 = ] [ drop +msgpack-nil+ ] }
+ { [ dup 0xc2 = ] [ drop f ] }
+ { [ dup 0xc3 = ] [ drop t ] }
+ { [ dup 0x00 0x7f between? ] [ ] }
+ { [ dup 0xe0 mask? ] [ 1array signed-be> ] }
+ { [ dup 0xcc = ] [ drop read1 ] }
+ { [ dup 0xcd = ] [ drop 2 read be> ] }
+ { [ dup 0xce = ] [ drop 4 read be> ] }
+ { [ dup 0xcf = ] [ drop 8 read be> ] }
+ { [ dup 0xd0 = ] [ drop 1 read signed-be> ] }
+ { [ dup 0xd1 = ] [ drop 2 read signed-be> ] }
+ { [ dup 0xd2 = ] [ drop 4 read signed-be> ] }
+ { [ dup 0xd3 = ] [ drop 8 read signed-be> ] }
+ { [ dup 0xca = ] [ drop 4 read be> bits>float ] }
+ { [ dup 0xcb = ] [ drop 8 read be> bits>double ] }
+ { [ dup 0xe0 mask 0xa0 = ] [ 0x1f mask read utf8 decode ] }
+ { [ dup 0xd9 = ] [ drop read1 read utf8 decode ] }
+ { [ dup 0xda = ] [ drop 2 read be> read utf8 decode ] }
+ { [ dup 0xdb = ] [ drop 4 read be> read utf8 decode ] }
+ { [ dup 0xc4 = ] [ drop read1 read B{ } like ] }
+ { [ dup 0xc5 = ] [ drop 2 read be> read B{ } like ] }
+ { [ dup 0xc6 = ] [ drop 4 read be> read B{ } like ] }
+ { [ dup 0xf0 mask 0x90 = ] [ 0x0f mask read-array ] }
+ { [ dup 0xdc = ] [ drop 2 read be> read-array ] }
+ { [ dup 0xdd = ] [ drop 4 read be> read-array ] }
+ { [ dup 0xf0 mask 0x80 = ] [ 0x0f mask read-map ] }
+ { [ dup 0xde = ] [ drop 2 read be> read-map ] }
+ { [ dup 0xdf = ] [ drop 4 read be> read-map ] }
+ { [ dup 0xd4 = ] [ drop 1 read-ext ] }
+ { [ dup 0xd5 = ] [ drop 2 read-ext ] }
+ { [ dup 0xd6 = ] [ drop 4 read-ext ] }
+ { [ dup 0xd7 = ] [ drop 8 read-ext ] }
+ { [ dup 0xd8 = ] [ drop 16 read-ext ] }
+ { [ dup 0xc7 = ] [ drop read1 read-ext ] }
+ { [ dup 0xc8 = ] [ drop 2 read be> read-ext ] }
+ { [ dup 0xc9 = ] [ drop 4 read be> read-ext ] }
+ [ unknown-format ]
+ } cond ;
+
+ERROR: cannot-convert obj ;
+
+GENERIC: write-msgpack ( obj -- )
+
+<PRIVATE
+
+M: +msgpack-nil+ write-msgpack drop 0xc0 write1 ;
+
+M: f write-msgpack drop 0xc2 write1 ;
+
+M: t write-msgpack drop 0xc3 write1 ;
+
+M: integer write-msgpack
+ dup 0 >= [
+ {
+ { [ dup 0x7f <= ] [ write1 ] }
+ { [ dup 0xff <= ] [ 0xcc write1 write1 ] }
+ { [ dup 0xffff <= ] [ 0xcd write1 2 >be write ] }
+ { [ dup 0xffffffff <= ] [ 0xce write1 4 >be write ] }
+ { [ dup 0xffffffffffffffff <= ] [ 0xcf write1 8 >be write ] }
+ [ cannot-convert ]
+ } cond
+ ] [
+ {
+ { [ dup -0x1f >= ] [ write1 ] }
+ { [ dup -0x80 >= ] [ 0xd0 write1 write1 ] }
+ { [ dup -0x8000 >= ] [ 0xd1 write1 2 >be write ] }
+ { [ dup -0x80000000 >= ] [ 0xd2 write1 4 >be write ] }
+ { [ dup -0x8000000000000000 >= ] [ 0xd3 write1 8 >be write ] }
+ [ cannot-convert ]
+ } cond
+ ] if ;
+
+M: float write-msgpack
+ 0xcb write1 double>bits 8 >be write ;
+
+M: string write-msgpack
+ dup length {
+ { [ dup 0x1f <= ] [ 0xa0 bitor write1 ] }
+ { [ dup 0xff <= ] [ 0xd9 write1 write1 ] }
+ { [ dup 0xffff <= ] [ 0xda write1 2 >be write ] }
+ { [ dup 0xffffffff <= ] [ 0xdb write1 4 >be write ] }
+ [ cannot-convert ]
+ } cond output-stream get utf8 encode-string ;
+
+M: byte-array write-msgpack
+ dup length {
+ { [ dup 0xff <= ] [ 0xc4 write1 write1 ] }
+ { [ dup 0xffff <= ] [ 0xc5 write1 2 >be write ] }
+ { [ dup 0xffffffff <= ] [ 0xc6 write1 4 >be write ] }
+ [ cannot-convert ]
+ } cond write ;
+
+: write-array-header ( n -- )
+ {
+ { [ dup 0xf <= ] [ 0x90 bitor write1 ] }
+ { [ dup 0xffff <= ] [ 0xdc write1 2 >be write ] }
+ { [ dup 0xffffffff <= ] [ 0xdd write1 4 >be write ] }
+ [ cannot-convert ]
+ } cond ;
+
+M: sequence write-msgpack
+ dup length write-array-header [ write-msgpack ] each ;
+
+: write-map-header ( n -- )
+ {
+ { [ dup 0xf <= ] [ 0x80 bitor write1 ] }
+ { [ dup 0xffff <= ] [ 0xde write1 2 >be write ] }
+ { [ dup 0xffffffff <= ] [ 0xdf write1 4 >be write ] }
+ [ cannot-convert ]
+ } cond ;
+
+M: assoc write-msgpack
+ dup assoc-size write-map-header
+ [ [ write-msgpack ] bi@ ] assoc-each ;
+
+PRIVATE>
+
+GENERIC: msgpack> ( seq -- obj )
+
+M: string msgpack>
+ [ read-msgpack ] with-string-reader ;
+
+M: byte-array msgpack>
+ binary [ read-msgpack ] with-byte-reader ;
+
+: >msgpack ( obj -- bytes )
+ binary [ write-msgpack ] with-byte-writer ;
--- /dev/null
+Support for msgpack protocol.
--- /dev/null
+file formats
--- /dev/null
+John Benediktsson
--- /dev/null
+Parsers for Tom's Obvious, Minimal Language (TOML).
--- /dev/null
+USING: help.markup help.syntax kernel strings ;
+IN: toml
+
+HELP: toml>
+{ $values { "string" string } { "assoc" object } }
+{ $description "Decodes a configuration from the TOML format, represented as a " { $link string } "." } ;
+
+ARTICLE: "toml" "Tom's Obvious Markup Language (TOML)"
+"Tom's Obvious Markup Language (TOML) is described further in "
+{ $url "https://en.wikipedia.org/wiki/TOML" } "."
+$nl
+"Decoding support for the TOML protocol:"
+{ $subsections
+ toml>
+} ;
+
+ABOUT: "toml"
--- /dev/null
+USING: multiline toml tools.test ;
+
+{
+ H{
+ { "title" "TOML Example" }
+ { "hosts" { "alpha" "omega" } }
+ {
+ "owner"
+ H{
+ { "name" "Tom Preston-Werner" }
+ { "organization" "GitHub" }
+ {
+ "bio"
+ "GitHub Cofounder & CEO\nLikes tater tots and beer."
+ }
+ { "dob" "1979-05-27T07:32:00Z" }
+ }
+ }
+ {
+ "database"
+ H{
+ { "server" "192.168.1.1" }
+ { "ports" { 8001 8001 8002 } }
+ { "connection_max" 5000 }
+ { "enabled" t }
+ }
+ }
+ {
+ "servers"
+ H{
+ {
+ "alpha"
+ H{
+ { "ip" "10.0.0.1" }
+ { "dc" "eqdc10" }
+ }
+ }
+ {
+ "beta"
+ H{
+ { "ip" "10.0.0.2" }
+ { "dc" "eqdc10" }
+ { "country" "中国" }
+ }
+ }
+ }
+ }
+ {
+ "clients"
+ H{
+ { "data" { { "gamma" "delta" } { 1 2 } } }
+ }
+ }
+ {
+ "products"
+ V{
+ H{
+ { "name" "Hammer" }
+ { "sku" 738594937 }
+ }
+ H{
+ { "name" "Nail" }
+ { "sku" 284758393 }
+ { "color" "gray" }
+ }
+ }
+ }
+ }
+} [
+ [=[
+
+# This is a TOML document. Boom.
+
+title = "TOML Example"
+
+[owner]
+name = "Tom Preston-Werner"
+organization = "GitHub"
+bio = "GitHub Cofounder & CEO\nLikes tater tots and beer."
+dob = 1979-05-27T07:32:00Z # First class dates? Why not?
+
+[database]
+server = "192.168.1.1"
+ports = [ 8001, 8001, 8002 ]
+connection_max = 5000
+enabled = true
+
+[servers]
+
+ # You can indent as you please. Tabs or spaces. TOML don't care.
+ [servers.alpha]
+ ip = "10.0.0.1"
+ dc = "eqdc10"
+
+ [servers.beta]
+ ip = "10.0.0.2"
+ dc = "eqdc10"
+ country = "中国" # This should be parsed as UTF-8
+
+[clients]
+data = [ ["gamma", "delta"], [1, 2] ] # just an update to make sure parsers support it
+
+# Line breaks are OK when inside arrays
+hosts = [
+ "alpha",
+ "omega"
+]
+
+# Products
+
+ [[products]]
+ name = "Hammer"
+ sku = 738594937
+
+ [[products]]
+ name = "Nail"
+ sku = 284758393
+ color = "gray"
+
+ ]=] toml>
+] unit-test
+
+{
+ H{
+ { "deps" H{
+ { "temp_targets" H{ { "case" 72.0 } } } }
+ }
+ }
+} [
+ "[deps]
+ temp_targets = { case = 72.0 }" toml>
+] unit-test
--- /dev/null
+! Copyright (C) 2019 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays assocs hashtables kernel locals make
+math.parser peg peg.parsers regexp sequences splitting
+strings.parser ;
+
+IN: toml
+
+ERROR: duplicate-key key ;
+
+ERROR: unknown-value value ;
+
+<PRIVATE
+
+! FIXME: key = 1234abcd # should error!
+
+TUPLE: table name array? entries ;
+
+TUPLE: entry key value ;
+
+: boolean-parser ( -- parser )
+ "true" token [ drop t ] action
+ "false" token [ drop f ] action
+ 2choice ;
+
+: digits ( parser -- parser )
+ "_" token [ drop f ] action 2choice repeat1 [ sift ] action ;
+
+: sign ( -- parser )
+ "+" token "-" token 2choice ;
+
+: hexdigit ( -- parser )
+ [
+ CHAR: 0 CHAR: 9 range ,
+ CHAR: a CHAR: f range ,
+ CHAR: A CHAR: F range ,
+ ] choice* ;
+
+: hex ( -- parser )
+ "0x" token hide hexdigit digits 2seq [ first hex> ] action ;
+
+: decdigit ( -- parser )
+ CHAR: 0 CHAR: 9 range ;
+
+: dec ( -- parser )
+ decdigit digits [ dec> ] action ;
+
+: octdigit ( -- parser )
+ CHAR: 0 CHAR: 7 range ;
+
+: oct ( -- parser )
+ "0o" token hide octdigit digits 2seq [ first oct> ] action ;
+
+: bindigit ( -- parser )
+ CHAR: 0 CHAR: 1 range ;
+
+: bin ( -- parser )
+ "0b" token hide bindigit digits 2seq [ first bin> ] action ;
+
+: integer-parser ( -- parser )
+ hex oct bin dec 4choice ;
+
+: float ( -- parser )
+ [
+ sign optional ,
+ decdigit digits optional ,
+ "." token ,
+ decdigit digits optional ,
+ "e" token "E" token 2choice
+ sign optional
+ decdigit digits optional 3seq optional ,
+ ] seq* [ unclip-last append "" concat-as string>number ] action ;
+
+: +inf ( -- parser )
+ "+" token optional "inf" token 2seq [ drop 1/0. ] action ;
+
+: -inf ( -- parser )
+ "-inf" token [ drop -1/0. ] action ;
+
+: nan ( -- parser )
+ sign optional "nan" token 2seq
+ [ drop NAN: 8000000000000 ] action ;
+
+: float-parser ( -- parser )
+ float +inf -inf nan 4choice ;
+
+: escaped ( -- parser )
+ "\\" token hide [ "btnfr\"\\" member-eq? ] satisfy 2seq
+ [ first escape ] action ;
+
+: unicode ( -- parser )
+ "\\u" token hide hexdigit 4 exactly-n 2seq
+ "\\U" token hide hexdigit 8 exactly-n 2seq
+ 2choice [ first hex> ] action ;
+
+: basic-string ( -- parser )
+ escaped unicode [ "\"\n" member? not ] satisfy 3choice repeat0
+ "\"" dup surrounded-by ;
+
+: literal-string ( -- parser )
+ [ "'\n" member? not ] satisfy repeat0
+ "'" dup surrounded-by ;
+
+: single-string ( -- parser )
+ basic-string literal-string 2choice [ "" like ] action ;
+
+: multi-basic-string ( -- parser )
+ escaped unicode [ CHAR: \" = not ] satisfy 3choice repeat0
+ "\"\"\"" dup surrounded-by ;
+
+: multi-literal-string ( -- parser )
+ [ CHAR: ' = not ] satisfy repeat0
+ "'''" dup surrounded-by ;
+
+: multi-string ( -- parser )
+ multi-basic-string multi-literal-string 2choice [
+ "" like "\n" ?head drop
+ R/ \\[ \t\r\n]*\n[ \t\r\n]*/m "" re-replace
+ ] action ;
+
+: string-parser ( -- parser )
+ multi-string single-string 2choice ;
+
+: date-parser ( -- parser )
+ [
+ decdigit 4 exactly-n ,
+ "-" token ,
+ decdigit 2 exactly-n ,
+ "-" token ,
+ decdigit 2 exactly-n ,
+ ] seq* [ "" concat-as ] action ;
+
+: time-parser ( -- parser )
+ [
+ decdigit 2 exactly-n ,
+ ":" token ,
+ decdigit 2 exactly-n ,
+ ":" token ,
+ decdigit 2 exactly-n ,
+ "." token decdigit repeat1 2seq optional ,
+ ] seq* [ "" concat-as ] action ;
+
+: timezone-parser ( -- parser )
+ "Z" token
+ "-" token
+ decdigit 2 exactly-n ":" token
+ decdigit 2 exactly-n 4seq [ "" concat-as ] action
+ 2choice ;
+
+: datetime-parser ( -- parser )
+ [
+ date-parser ,
+ "T" token " " token 2choice ,
+ time-parser ,
+ timezone-parser optional ,
+ ] seq* [ "" concat-as ] action ;
+
+: space ( -- parser )
+ [ " \t" member? ] satisfy repeat0 ;
+
+: whitespace ( -- parser )
+ [ " \t\r\n" member? ] satisfy repeat0 ;
+
+DEFER: value-parser
+
+: array-parser ( -- parser )
+ [
+ "[" token hide ,
+ whitespace hide ,
+ value-parser
+ whitespace "," token whitespace pack list-of ,
+ whitespace hide ,
+ "]" token hide ,
+ ] seq* [ first { } like ] action ;
+
+DEFER: key-value-parser
+
+DEFER: update-toml
+
+: inline-table-parser ( -- parser )
+ [
+ "{" token hide ,
+ whitespace hide ,
+ key-value-parser
+ whitespace "," token whitespace pack list-of ,
+ whitespace hide ,
+ "}" token hide ,
+ ] seq* [
+ first [ length <hashtable> ] keep [ update-toml ] each
+ ] action ;
+
+: value-parser ( -- parser )
+ [
+ [
+ boolean-parser ,
+ datetime-parser ,
+ date-parser ,
+ time-parser ,
+ float-parser ,
+ integer-parser ,
+ string-parser ,
+ array-parser ,
+ inline-table-parser ,
+ ] choice*
+ ] delay ;
+
+: name-parser ( -- parser )
+ [
+ CHAR: A CHAR: Z range ,
+ CHAR: a CHAR: z range ,
+ CHAR: 0 CHAR: 9 range ,
+ "_" token [ first ] action ,
+ "-" token [ first ] action ,
+ ] choice* repeat1 [ "" like ] action single-string 2choice ;
+
+: comment-parser ( -- parser )
+ [
+ space hide ,
+ "#" token ,
+ [ CHAR: \n = not ] satisfy repeat0 ,
+ ] seq* [ drop f ] action ;
+
+: key-parser ( -- parser )
+ name-parser "." token list-of [ { } like ] action ;
+
+: key-value-parser ( -- parser )
+ [
+ space hide ,
+ key-parser ,
+ space hide ,
+ "=" token hide ,
+ space hide ,
+ value-parser ,
+ comment-parser optional hide ,
+ ] seq* [ first2 entry boa ] action ;
+
+: line-parser ( -- parser )
+ "\n" token "\r\n" token 2choice ;
+
+:: table-name-parser ( begin end -- parser )
+ [
+ begin token hide ,
+ space hide ,
+ name-parser
+ space "." token space pack list-of
+ [ { } like ] action ,
+ space hide ,
+ end token hide ,
+ comment-parser optional hide ,
+ ] seq* ;
+
+: table-parser ( -- parser )
+ [
+ space hide ,
+ "[[" "]]" table-name-parser [ t suffix! ] action
+ "[" "]" table-name-parser [ f suffix! ] action
+ 2choice ,
+ whitespace hide ,
+ key-value-parser line-parser list-of optional ,
+ ] seq* [ first2 [ first2 ] dip table boa ] action ;
+
+: toml-parser ( -- parser )
+ [
+ whitespace hide ,
+ [
+ comment-parser ,
+ table-parser ,
+ key-value-parser ,
+ ] choice* whitespace list-of ,
+ whitespace hide ,
+ ] seq* [ first sift { } like ] action ;
+
+: check-no-key ( key assoc -- key assoc )
+ 2dup at* nip [ over duplicate-key ] when ;
+
+: deep-at ( keys assoc -- value )
+ swap [
+ over ?at [ nip ] [
+ H{ } clone [ swap rot check-no-key set-at ] keep
+ ] if
+ ] each ;
+
+GENERIC: update-toml ( assoc entry -- assoc )
+
+M: entry update-toml
+ [ key>> unclip-last [ over deep-at ] dip ] [ value>> ] bi
+ swap rot check-no-key set-at ;
+
+M: table update-toml
+ [ name>> unclip-last [ over deep-at ] dip ]
+ [ entries>> [ H{ } clone ] dip [ update-toml ] each swap rot ]
+ [ array?>> [ push-at ] [ check-no-key set-at ] if ] tri ;
+
+PRIVATE>
+
+: toml> ( string -- assoc )
+ [ H{ } clone ] dip toml-parser parse [ update-toml ] each ;
--- /dev/null
+John Benediktsson
--- /dev/null
+Support for uuencoding and uudecoding.
--- /dev/null
+USING: kernel tools.test uu ;
+IN: uu.tests
+
+CONSTANT: plain
+"The smooth-scaled python crept over the sleeping dog"
+
+CONSTANT: encoded
+"begin
+M5&AE('-M;V]T:\"US8V%L960@<'ET:&]N(&-R97!T(&]V97(@=&AE('-L965P
+':6YG(&1O9P
+end
+"
+
+{ t } [ plain string>uu encoded = ] unit-test
+{ t } [ encoded uu>string plain = ] unit-test
+
+{ "Cat" } [
+ "begin 644 cat.txt\n#0V%T\n`\nend\n" uu>string
+] unit-test
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: io io.streams.string kernel locals make math math.bitwise
+math.order namespaces sequences ;
+
+IN: uu
+
+<PRIVATE
+
+ERROR: bad-length seq ;
+
+: check-length ( seq -- seq )
+ dup length 45 > [ bad-length ] when ; inline
+
+:: binary>ascii ( seq -- seq' )
+ 0 :> char!
+ 0 :> bits!
+ seq check-length [
+ dup length CHAR: \s + ,
+
+ [ dup empty? bits zero? and ] [
+
+ char 8 shift char!
+ bits 8 + bits!
+
+ dup empty? [
+ unclip-slice char bitor char!
+ ] unless
+
+ [ bits 6 >= ] [
+ bits 6 -
+ [ char swap neg shift 0x3f bitand CHAR: \s + , ]
+ [ bits! ] bi
+ ] while
+
+ ] until drop
+ ] "" make ;
+
+ERROR: illegal-character ch ;
+
+: check-illegal-character ( ch -- ch )
+ dup CHAR: \s dup 64 + between? [ illegal-character ] unless ;
+
+:: ascii>binary ( seq -- seq' )
+ 0 :> char!
+ 0 :> bits!
+
+ seq unclip-slice CHAR: \s - :> len!
+
+ [
+ [ dup empty? not len 0 > and ] [
+ dup empty? [ 0 ] [ unclip-slice ] if
+ dup "\r\n\0" member? [
+ drop 0
+ ] [
+ check-illegal-character
+ CHAR: \s -
+ ] if
+
+ char 6 shift bitor char!
+ bits 6 + bits!
+
+ bits 8 >= [
+ bits 8 -
+ [ char swap neg shift 0xff bitand , ]
+ [ on-bits char bitand char! ]
+ [ bits! ] tri
+ len 1 - len!
+ ] when
+ ] while drop
+
+ ] "" make ;
+
+PRIVATE>
+
+: uu-encode ( -- )
+ "begin" print
+ input-stream get [ binary>ascii print ] 45 (each-stream-block)
+ "end" print ;
+
+: string>uu ( seq -- seq' )
+ [ [ uu-encode ] with-string-writer ] with-string-reader ;
+
+: uu-decode ( -- )
+ [ [ "begin" head? ] [ not ] bi or ] [ readln ] do until
+ [
+ dup [ "end" head? ] [ not ] bi or
+ [ drop t ] [ ascii>binary write f ] if
+ ] [ readln ] do until ;
+
+: uu>string ( seq -- seq )
+ [ [ uu-decode ] with-string-writer ] with-string-reader ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: byte-arrays help.markup help.syntax io kernel sequences strings ;
-
-IN: cbor
-
-HELP: read-cbor
-{ $values { "obj" object } }
-{ $description "Decodes an object that was serialized in the CBOR format, reading from an " { $link input-stream } "." } ;
-
-HELP: write-cbor
-{ $values { "obj" object } }
-{ $description "Encodes an object into the CBOR format, writing to an " { $link output-stream } "." } ;
-
-HELP: cbor>
-{ $values { "seq" sequence } { "obj" object } }
-{ $description "Decodes an object from the CBOR format, represented as a " { $link byte-array } " or " { $link string } "." } ;
-
-HELP: >cbor
-{ $values { "obj" object } { "bytes" byte-array } }
-{ $description "Encodes an object into the CBOR format." } ;
-
-ARTICLE: "cbor" "Concise Binary Object Representation (CBOR)"
-"The Concise Binary Object Representation (CBOR) is defined in RFC 7049."
-$nl
-"Decoding support for the CBOR protocol:"
-{ $subsections
- read-cbor
- cbor>
-}
-"Encoding support for the CBOR protocol:"
-{ $subsections
- write-cbor
- >cbor
-} ;
-
-ABOUT: "cbor"
+++ /dev/null
-USING: arrays assocs calendar cbor kernel literals locals math
-math.parser math.ranges tools.test urls ;
-
-{
- { 0 "00" }
- { 1 "01" }
- { 10 "0a" }
- { 23 "17" }
- { 24 "1818" }
- { 25 "1819" }
- { 100 "1864" }
- { 1000 "1903e8" }
- { 1000000 "1a000f4240" }
- { 1000000000000 "1b000000e8d4a51000" }
- { 18446744073709551615 "1bffffffffffffffff" }
- { 18446744073709551616 "c249010000000000000000" }
- { -18446744073709551616 "3bffffffffffffffff" }
- { -18446744073709551617 "c349010000000000000000" }
- { -1 "20" }
- { -10 "29" }
- { -100 "3863" }
- { -1000 "3903e7" }
- { 0.0 "f90000" }
- { -0.0 "f98000" }
- { 1.0 "f93c00" }
- { 1.1 "fb3ff199999999999a" }
- { 1.5 "f93e00" }
- { 65504.0 "f97bff" }
- { 100000.0 "fa47c35000" }
- { 3.4028234663852886e+38 "fa7f7fffff" }
- { 1.0e+300 "fb7e37e43c8800759c" }
- ! FIXME { 5.960464477539063e-8 "f90001" }
- { 0.00006103515625 "f90400" }
- { -4.0 "f9c400" }
- { -4.1 "fbc010666666666666" }
- { 1/0. "f97c00" }
- { NAN: 8000000000000 "f97e00" }
- { -1/0. "f9fc00" }
- { 1/0. "fa7f800000" }
- { NAN: 8000000000000 "fa7fc00000" }
- { -1/0. "faff800000" }
- { 1/0. "fb7ff0000000000000" }
- { NAN: 8000000000000 "fb7ff8000000000000" }
- { -1/0. "fbfff0000000000000" }
- { f "f4" }
- { t "f5" }
- { +cbor-nil+ "f6" }
- { +cbor-undefined+ "f7" }
- { T{ cbor-simple f 16 } "f0" }
- { T{ cbor-simple f 24 } "f818" }
- { T{ cbor-simple f 255 } "f8ff" }
- {
- T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } }
- "c074323031332d30332d32315432303a30343a30305a"
- }
- {
- T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } }
- "c11a514b67b0"
- }
- {
- T{ timestamp { year 2013 } { month 3 } { day 21 } { hour 20 } { minute 4 } { second 0.5 } }
- "c1fb41d452d9ec200000"
- }
- { T{ cbor-tagged f 23 B{ 1 2 3 4 } } "d74401020304" }
- { T{ cbor-tagged f 24 B{ 0x64 0x49 0x45 0x54 0x46 } } "d818456449455446" }
- { URL" http://www.example.com" "d82076687474703a2f2f7777772e6578616d706c652e636f6d" }
- { B{ } "40" }
- { B{ 1 2 3 4 } "4401020304" }
- { B{ 0xaa 0xbb 0xcc 0xdd 0xee 0xff 0x99 } "5F44aabbccdd43eeff99ff" }
- { "" "60" }
- { "a" "6161" }
- { "IETF" "6449455446" }
- { "\"\\" "62225c" }
- { "\u0000fc" "62c3bc" }
- { "\u006c34" "63e6b0b4" }
- ! FIXME { "\u00d800\u00dd51" "64f0908591" }
- { { } "80" }
- { { 1 2 3 } "83010203" }
- { { 1 { 2 3 } { 4 5 } } "8301820203820405" }
- ${ 25 [1,b] >array "98190102030405060708090a0b0c0d0e0f101112131415161718181819" }
- { { } "a0" }
- { { { 1 2 } { 3 4 } } "a201020304" }
- { { { "a" 1 } { "b" { 2 3 } } } "a26161016162820203" }
- { { "a" { { "b" "c" } } } "826161a161626163" }
- {
- { { "a" "A" } { "b" "B" } { "c" "C" } { "d" "D" } { "e" "E" } }
- "a56161614161626142616361436164614461656145"
- }
- { { 1 { 2 3 } { 4 5 } } "9f018202039f0405ffff" }
- { { 1 { 2 3 } { 4 5 } } "9f01820203820405ff" }
- { { 1 { 2 3 } { 4 5 } } "83018202039f0405ff" }
- { { 1 { 2 3 } { 4 5 } } "83019f0203ff820405" }
- ${ 25 [1,b] >array "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff" }
- { { { "a" 1 } { "b" { 2 3 } } } "bf61610161629f0203ffff" }
- { { "a" { { "b" "c" } } } "826161bf61626163ff" }
- { { { "Fun" t } { "Amt" -2 } } "bf6346756ef563416d7421ff" }
-} [| value hex-string |
-
- hex-string hex-string>bytes :> bytes
-
- value fp-nan? [
- { t t } [
- bytes cbor> [ fp-nan? ] [ fp-nan-payload ] bi
- value fp-nan-payload =
- ] unit-test
- ] [
- { value } [ bytes cbor> ] unit-test
- ] if
-
-] assoc-each
+++ /dev/null
-! Copyright (C) 2019 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors arrays assocs base64 byte-arrays calendar
-calendar.format calendar.parser 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 present sequences strings urls ;
-
-IN: cbor
-
-DEFER: read-cbor
-
-SINGLETON: +cbor-nil+
-
-SINGLETON: +cbor-undefined+
-
-SINGLETON: +cbor-break+
-
-SINGLETON: +cbor-indefinite+
-
-TUPLE: cbor-tagged tag item ;
-
-TUPLE: cbor-simple value ;
-
-<PRIVATE
-
-: read-unsigned ( info -- n )
- dup 24 < [
- {
- { 24 [ read1 ] }
- { 25 [ 2 read be> ] }
- { 26 [ 4 read be> ] }
- { 27 [ 8 read be> ] }
- { 31 [ +cbor-indefinite+ ] }
- } case
- ] unless ;
-
-: read-bytestring ( info -- byte-array )
- read-unsigned dup +cbor-indefinite+ = [
- drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip concat
- ] [
- read [ B{ } ] unless*
- ] if ;
-
-: read-textstring ( info -- string )
- read-bytestring utf8 decode ;
-
-: read-array ( info -- array )
- read-unsigned dup +cbor-indefinite+ = [
- drop [ read-cbor dup +cbor-break+ = not ] [ ] produce nip
- ] [
- [ read-cbor ] replicate
- ] if ;
-
-: read-map ( info -- alist )
- read-unsigned dup +cbor-indefinite+ = [
- drop [ read-cbor dup +cbor-break+ = not ]
- [ read-cbor 2array ] produce nip
- ] [
- [ read-cbor read-cbor 2array ] replicate
- ] if ;
-
-: read-tagged ( info -- tagged )
- read-unsigned read-cbor swap {
- { 0 [ rfc3339>timestamp ] }
- { 1 [ unix-time>timestamp ] }
- { 2 [ be> ] }
- { 3 [ be> neg 1 - ] }
- { 32 [ >url ] }
- { 33 [ base64> ] }
- [ swap cbor-tagged boa ]
- } case ;
-
-: read-float ( info -- float )
- dup 20 < [ cbor-simple boa ] [
- {
- { 20 [ f ] }
- { 21 [ t ] }
- { 22 [ +cbor-nil+ ] }
- { 23 [ +cbor-undefined+ ] }
- { 24 [ read1 cbor-simple boa ] }
- { 25 [ 2 read be> bits>half ] }
- { 26 [ 4 read be> bits>float ] }
- { 27 [ 8 read be> bits>double ] }
- { 31 [ +cbor-break+ ] }
- } case
- ] if ;
-
-PRIVATE>
-
-: read-cbor ( -- obj )
- read1 [ 5 bits ] [ -5 shift 3 bits ] bi {
- { 0 [ read-unsigned ] }
- { 1 [ read-unsigned neg 1 - ] }
- { 2 [ read-bytestring ] }
- { 3 [ read-textstring ] }
- { 4 [ read-array ] }
- { 5 [ read-map ] }
- { 6 [ read-tagged ] }
- { 7 [ read-float ] }
- } case ;
-
-GENERIC: write-cbor ( obj -- )
-
-<PRIVATE
-
-M: f write-cbor drop 0xf4 write1 ;
-
-M: t write-cbor drop 0xf5 write1 ;
-
-M: +cbor-nil+ write-cbor drop 0xf6 write1 ;
-
-M: +cbor-undefined+ write-cbor drop 0xf7 write1 ;
-
-: write-integer ( 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 ] }
- [
- -5 shift 2 + 0xc0 bitor write1
- dup bit-length 8 /mod zero? [ 1 + ] unless
- >be write-cbor
- ]
- } cond ;
-
-M: integer write-cbor
- dup 0 >= [ 0 write-integer ] [ neg 1 - 1 write-integer ] if ;
-
-M: float write-cbor 0xfb write1 double>bits 8 >be write ;
-
-M: byte-array write-cbor dup length 2 write-integer write ;
-
-M: string write-cbor dup length 3 write-integer utf8 encode write ;
-
-M: sequence write-cbor
- dup length 4 write-integer [ write-cbor ] each ;
-
-M: assoc write-cbor
- dup length 5 write-integer [ [ write-cbor ] bi@ ] assoc-each ;
-
-M: timestamp write-cbor
- 0 6 write-integer timestamp>rfc3339 write-cbor ;
-
-M: url write-cbor
- 32 6 write-integer present write-cbor ;
-
-M: cbor-tagged write-cbor
- dup tag>> 6 write-integer item>> write-cbor ;
-
-M: cbor-simple write-cbor
- value>> 7 write-integer ;
-
-PRIVATE>
-
-GENERIC: cbor> ( seq -- obj )
-
-M: string cbor>
- [ read-cbor ] with-string-reader ;
-
-M: byte-array cbor>
- binary [ read-cbor ] with-byte-reader ;
-
-: >cbor ( obj -- bytes )
- binary [ write-cbor ] with-byte-writer ;
+++ /dev/null
-Support for Concise Binary Object Representation (CBOR)
+++ /dev/null
-file formats
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: byte-arrays help.markup help.syntax io kernel sequences strings ;
-
-IN: msgpack
-
-HELP: read-msgpack
-{ $values { "obj" object } }
-{ $description "Decodes an object that was serialized in the MessagePack format, reading from an " { $link input-stream } "." } ;
-
-HELP: write-msgpack
-{ $values { "obj" object } }
-{ $description "Encodes an object into the MessagePack format, writing to an " { $link output-stream } "." } ;
-
-HELP: msgpack>
-{ $values { "seq" sequence } { "obj" object } }
-{ $description "Decodes an object from the MessagePack format, represented as a " { $link byte-array } " or " { $link string } "." } ;
-
-HELP: >msgpack
-{ $values { "obj" object } { "bytes" byte-array } }
-{ $description "Encodes an object into the MessagePack format." } ;
-
-ARTICLE: "msgpack" "MessagePack"
-"Decoding support for the MessagePack protocol:"
-{ $subsections
- read-msgpack
- msgpack>
-}
-"Encoding support for the MessagePack protocol:"
-{ $subsections
- write-msgpack
- >msgpack
-} ;
-
-ABOUT: "msgpack"
+++ /dev/null
-USING: io.streams.string kernel math msgpack sequences
-tools.test ;
-
-{
- {
- +msgpack-nil+
- f
- t
- -1
- -31
- 128
- -1152921504606846976
- 1.5
- 1.23434536
- "hello"
- { 1 1234 123456789 }
- H{ { 1 "hello" } { 2 "goodbye" } }
- }
-} [
-
- {
- "\xc0"
- "\xc2"
- "\xc3"
- "\xff"
- "\xe1"
- "\xcc\x80"
- "\xd3\xf0\x00\x00\x00\x00\x00\x00\x00"
- "\xcb?\xf8\x00\x00\x00\x00\x00\x00"
- "\xcb?\xf3\xbf\xe0\xeb\x92\xb5\xa5"
- "\xa5hello"
- "\x93\x01\xcd\x04\xd2\xce\x07[\xcd\x15"
- "\x82\x01\xa5hello\x02\xa7goodbye"
- } [ msgpack> ] map
-] unit-test
-
-{ t } [
- {
- +msgpack-nil+
- f
- t
- -1
- -31
- 128
- -1152921504606846976
- 1.5
- 1.23434536
- "hello"
- { 1 1234 123456789 }
- H{ { 1 "hello" } { 2 "goodbye" } }
- } [ dup >msgpack msgpack> = ] all?
-] unit-test
-
-[ 64 2^ >msgpack ] [ cannot-convert? ] must-fail-with
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays assocs byte-arrays combinators grouping hashtables
-io io.binary io.encodings io.encodings.binary
-io.encodings.string io.encodings.utf8 io.streams.byte-array
-io.streams.string kernel math math.bitwise math.order namespaces
-sequences strings ;
-
-IN: msgpack
-
-DEFER: read-msgpack
-
-<PRIVATE
-
-: read-array ( n -- obj )
- [ read-msgpack ] replicate ;
-
-: read-map ( n -- obj )
- 2 * read-array 2 group >hashtable ;
-
-: read-ext ( n -- obj )
- read be> [ 1 read signed-be> ] dip read 2array ;
-
-PRIVATE>
-
-SINGLETON: +msgpack-nil+
-
-ERROR: unknown-format n ;
-
-: read-msgpack ( -- obj )
- read1 {
- { [ dup 0xc0 = ] [ drop +msgpack-nil+ ] }
- { [ dup 0xc2 = ] [ drop f ] }
- { [ dup 0xc3 = ] [ drop t ] }
- { [ dup 0x00 0x7f between? ] [ ] }
- { [ dup 0xe0 mask? ] [ 1array signed-be> ] }
- { [ dup 0xcc = ] [ drop read1 ] }
- { [ dup 0xcd = ] [ drop 2 read be> ] }
- { [ dup 0xce = ] [ drop 4 read be> ] }
- { [ dup 0xcf = ] [ drop 8 read be> ] }
- { [ dup 0xd0 = ] [ drop 1 read signed-be> ] }
- { [ dup 0xd1 = ] [ drop 2 read signed-be> ] }
- { [ dup 0xd2 = ] [ drop 4 read signed-be> ] }
- { [ dup 0xd3 = ] [ drop 8 read signed-be> ] }
- { [ dup 0xca = ] [ drop 4 read be> bits>float ] }
- { [ dup 0xcb = ] [ drop 8 read be> bits>double ] }
- { [ dup 0xe0 mask 0xa0 = ] [ 0x1f mask read utf8 decode ] }
- { [ dup 0xd9 = ] [ drop read1 read utf8 decode ] }
- { [ dup 0xda = ] [ drop 2 read be> read utf8 decode ] }
- { [ dup 0xdb = ] [ drop 4 read be> read utf8 decode ] }
- { [ dup 0xc4 = ] [ drop read1 read B{ } like ] }
- { [ dup 0xc5 = ] [ drop 2 read be> read B{ } like ] }
- { [ dup 0xc6 = ] [ drop 4 read be> read B{ } like ] }
- { [ dup 0xf0 mask 0x90 = ] [ 0x0f mask read-array ] }
- { [ dup 0xdc = ] [ drop 2 read be> read-array ] }
- { [ dup 0xdd = ] [ drop 4 read be> read-array ] }
- { [ dup 0xf0 mask 0x80 = ] [ 0x0f mask read-map ] }
- { [ dup 0xde = ] [ drop 2 read be> read-map ] }
- { [ dup 0xdf = ] [ drop 4 read be> read-map ] }
- { [ dup 0xd4 = ] [ drop 1 read-ext ] }
- { [ dup 0xd5 = ] [ drop 2 read-ext ] }
- { [ dup 0xd6 = ] [ drop 4 read-ext ] }
- { [ dup 0xd7 = ] [ drop 8 read-ext ] }
- { [ dup 0xd8 = ] [ drop 16 read-ext ] }
- { [ dup 0xc7 = ] [ drop read1 read-ext ] }
- { [ dup 0xc8 = ] [ drop 2 read be> read-ext ] }
- { [ dup 0xc9 = ] [ drop 4 read be> read-ext ] }
- [ unknown-format ]
- } cond ;
-
-ERROR: cannot-convert obj ;
-
-GENERIC: write-msgpack ( obj -- )
-
-<PRIVATE
-
-M: +msgpack-nil+ write-msgpack drop 0xc0 write1 ;
-
-M: f write-msgpack drop 0xc2 write1 ;
-
-M: t write-msgpack drop 0xc3 write1 ;
-
-M: integer write-msgpack
- dup 0 >= [
- {
- { [ dup 0x7f <= ] [ write1 ] }
- { [ dup 0xff <= ] [ 0xcc write1 write1 ] }
- { [ dup 0xffff <= ] [ 0xcd write1 2 >be write ] }
- { [ dup 0xffffffff <= ] [ 0xce write1 4 >be write ] }
- { [ dup 0xffffffffffffffff <= ] [ 0xcf write1 8 >be write ] }
- [ cannot-convert ]
- } cond
- ] [
- {
- { [ dup -0x1f >= ] [ write1 ] }
- { [ dup -0x80 >= ] [ 0xd0 write1 write1 ] }
- { [ dup -0x8000 >= ] [ 0xd1 write1 2 >be write ] }
- { [ dup -0x80000000 >= ] [ 0xd2 write1 4 >be write ] }
- { [ dup -0x8000000000000000 >= ] [ 0xd3 write1 8 >be write ] }
- [ cannot-convert ]
- } cond
- ] if ;
-
-M: float write-msgpack
- 0xcb write1 double>bits 8 >be write ;
-
-M: string write-msgpack
- dup length {
- { [ dup 0x1f <= ] [ 0xa0 bitor write1 ] }
- { [ dup 0xff <= ] [ 0xd9 write1 write1 ] }
- { [ dup 0xffff <= ] [ 0xda write1 2 >be write ] }
- { [ dup 0xffffffff <= ] [ 0xdb write1 4 >be write ] }
- [ cannot-convert ]
- } cond output-stream get utf8 encode-string ;
-
-M: byte-array write-msgpack
- dup length {
- { [ dup 0xff <= ] [ 0xc4 write1 write1 ] }
- { [ dup 0xffff <= ] [ 0xc5 write1 2 >be write ] }
- { [ dup 0xffffffff <= ] [ 0xc6 write1 4 >be write ] }
- [ cannot-convert ]
- } cond write ;
-
-: write-array-header ( n -- )
- {
- { [ dup 0xf <= ] [ 0x90 bitor write1 ] }
- { [ dup 0xffff <= ] [ 0xdc write1 2 >be write ] }
- { [ dup 0xffffffff <= ] [ 0xdd write1 4 >be write ] }
- [ cannot-convert ]
- } cond ;
-
-M: sequence write-msgpack
- dup length write-array-header [ write-msgpack ] each ;
-
-: write-map-header ( n -- )
- {
- { [ dup 0xf <= ] [ 0x80 bitor write1 ] }
- { [ dup 0xffff <= ] [ 0xde write1 2 >be write ] }
- { [ dup 0xffffffff <= ] [ 0xdf write1 4 >be write ] }
- [ cannot-convert ]
- } cond ;
-
-M: assoc write-msgpack
- dup assoc-size write-map-header
- [ [ write-msgpack ] bi@ ] assoc-each ;
-
-PRIVATE>
-
-GENERIC: msgpack> ( seq -- obj )
-
-M: string msgpack>
- [ read-msgpack ] with-string-reader ;
-
-M: byte-array msgpack>
- binary [ read-msgpack ] with-byte-reader ;
-
-: >msgpack ( obj -- bytes )
- binary [ write-msgpack ] with-byte-writer ;
+++ /dev/null
-Support for msgpack protocol.
+++ /dev/null
-file formats
+++ /dev/null
-John Benediktsson
+++ /dev/null
-Parsers for Tom's Obvious, Minimal Language (TOML).
+++ /dev/null
-USING: help.markup help.syntax kernel strings ;
-IN: toml
-
-HELP: toml>
-{ $values { "string" string } { "assoc" object } }
-{ $description "Decodes a configuration from the TOML format, represented as a " { $link string } "." } ;
-
-ARTICLE: "toml" "Tom's Obvious Markup Language (TOML)"
-"Tom's Obvious Markup Language (TOML) is described further in "
-{ $url "https://en.wikipedia.org/wiki/TOML" } "."
-$nl
-"Decoding support for the TOML protocol:"
-{ $subsections
- toml>
-} ;
-
-ABOUT: "toml"
+++ /dev/null
-USING: multiline toml tools.test ;
-
-{
- H{
- { "title" "TOML Example" }
- { "hosts" { "alpha" "omega" } }
- {
- "owner"
- H{
- { "name" "Tom Preston-Werner" }
- { "organization" "GitHub" }
- {
- "bio"
- "GitHub Cofounder & CEO\nLikes tater tots and beer."
- }
- { "dob" "1979-05-27T07:32:00Z" }
- }
- }
- {
- "database"
- H{
- { "server" "192.168.1.1" }
- { "ports" { 8001 8001 8002 } }
- { "connection_max" 5000 }
- { "enabled" t }
- }
- }
- {
- "servers"
- H{
- {
- "alpha"
- H{
- { "ip" "10.0.0.1" }
- { "dc" "eqdc10" }
- }
- }
- {
- "beta"
- H{
- { "ip" "10.0.0.2" }
- { "dc" "eqdc10" }
- { "country" "中国" }
- }
- }
- }
- }
- {
- "clients"
- H{
- { "data" { { "gamma" "delta" } { 1 2 } } }
- }
- }
- {
- "products"
- V{
- H{
- { "name" "Hammer" }
- { "sku" 738594937 }
- }
- H{
- { "name" "Nail" }
- { "sku" 284758393 }
- { "color" "gray" }
- }
- }
- }
- }
-} [
- [=[
-
-# This is a TOML document. Boom.
-
-title = "TOML Example"
-
-[owner]
-name = "Tom Preston-Werner"
-organization = "GitHub"
-bio = "GitHub Cofounder & CEO\nLikes tater tots and beer."
-dob = 1979-05-27T07:32:00Z # First class dates? Why not?
-
-[database]
-server = "192.168.1.1"
-ports = [ 8001, 8001, 8002 ]
-connection_max = 5000
-enabled = true
-
-[servers]
-
- # You can indent as you please. Tabs or spaces. TOML don't care.
- [servers.alpha]
- ip = "10.0.0.1"
- dc = "eqdc10"
-
- [servers.beta]
- ip = "10.0.0.2"
- dc = "eqdc10"
- country = "中国" # This should be parsed as UTF-8
-
-[clients]
-data = [ ["gamma", "delta"], [1, 2] ] # just an update to make sure parsers support it
-
-# Line breaks are OK when inside arrays
-hosts = [
- "alpha",
- "omega"
-]
-
-# Products
-
- [[products]]
- name = "Hammer"
- sku = 738594937
-
- [[products]]
- name = "Nail"
- sku = 284758393
- color = "gray"
-
- ]=] toml>
-] unit-test
-
-{
- H{
- { "deps" H{
- { "temp_targets" H{ { "case" 72.0 } } } }
- }
- }
-} [
- "[deps]
- temp_targets = { case = 72.0 }" toml>
-] unit-test
+++ /dev/null
-! Copyright (C) 2019 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors arrays assocs hashtables kernel locals make
-math.parser peg peg.parsers regexp sequences splitting
-strings.parser ;
-
-IN: toml
-
-ERROR: duplicate-key key ;
-
-ERROR: unknown-value value ;
-
-<PRIVATE
-
-! FIXME: key = 1234abcd # should error!
-
-TUPLE: table name array? entries ;
-
-TUPLE: entry key value ;
-
-: boolean-parser ( -- parser )
- "true" token [ drop t ] action
- "false" token [ drop f ] action
- 2choice ;
-
-: digits ( parser -- parser )
- "_" token [ drop f ] action 2choice repeat1 [ sift ] action ;
-
-: sign ( -- parser )
- "+" token "-" token 2choice ;
-
-: hexdigit ( -- parser )
- [
- CHAR: 0 CHAR: 9 range ,
- CHAR: a CHAR: f range ,
- CHAR: A CHAR: F range ,
- ] choice* ;
-
-: hex ( -- parser )
- "0x" token hide hexdigit digits 2seq [ first hex> ] action ;
-
-: decdigit ( -- parser )
- CHAR: 0 CHAR: 9 range ;
-
-: dec ( -- parser )
- decdigit digits [ dec> ] action ;
-
-: octdigit ( -- parser )
- CHAR: 0 CHAR: 7 range ;
-
-: oct ( -- parser )
- "0o" token hide octdigit digits 2seq [ first oct> ] action ;
-
-: bindigit ( -- parser )
- CHAR: 0 CHAR: 1 range ;
-
-: bin ( -- parser )
- "0b" token hide bindigit digits 2seq [ first bin> ] action ;
-
-: integer-parser ( -- parser )
- hex oct bin dec 4choice ;
-
-: float ( -- parser )
- [
- sign optional ,
- decdigit digits optional ,
- "." token ,
- decdigit digits optional ,
- "e" token "E" token 2choice
- sign optional
- decdigit digits optional 3seq optional ,
- ] seq* [ unclip-last append "" concat-as string>number ] action ;
-
-: +inf ( -- parser )
- "+" token optional "inf" token 2seq [ drop 1/0. ] action ;
-
-: -inf ( -- parser )
- "-inf" token [ drop -1/0. ] action ;
-
-: nan ( -- parser )
- sign optional "nan" token 2seq
- [ drop NAN: 8000000000000 ] action ;
-
-: float-parser ( -- parser )
- float +inf -inf nan 4choice ;
-
-: escaped ( -- parser )
- "\\" token hide [ "btnfr\"\\" member-eq? ] satisfy 2seq
- [ first escape ] action ;
-
-: unicode ( -- parser )
- "\\u" token hide hexdigit 4 exactly-n 2seq
- "\\U" token hide hexdigit 8 exactly-n 2seq
- 2choice [ first hex> ] action ;
-
-: basic-string ( -- parser )
- escaped unicode [ "\"\n" member? not ] satisfy 3choice repeat0
- "\"" dup surrounded-by ;
-
-: literal-string ( -- parser )
- [ "'\n" member? not ] satisfy repeat0
- "'" dup surrounded-by ;
-
-: single-string ( -- parser )
- basic-string literal-string 2choice [ "" like ] action ;
-
-: multi-basic-string ( -- parser )
- escaped unicode [ CHAR: \" = not ] satisfy 3choice repeat0
- "\"\"\"" dup surrounded-by ;
-
-: multi-literal-string ( -- parser )
- [ CHAR: ' = not ] satisfy repeat0
- "'''" dup surrounded-by ;
-
-: multi-string ( -- parser )
- multi-basic-string multi-literal-string 2choice [
- "" like "\n" ?head drop
- R/ \\[ \t\r\n]*\n[ \t\r\n]*/m "" re-replace
- ] action ;
-
-: string-parser ( -- parser )
- multi-string single-string 2choice ;
-
-: date-parser ( -- parser )
- [
- decdigit 4 exactly-n ,
- "-" token ,
- decdigit 2 exactly-n ,
- "-" token ,
- decdigit 2 exactly-n ,
- ] seq* [ "" concat-as ] action ;
-
-: time-parser ( -- parser )
- [
- decdigit 2 exactly-n ,
- ":" token ,
- decdigit 2 exactly-n ,
- ":" token ,
- decdigit 2 exactly-n ,
- "." token decdigit repeat1 2seq optional ,
- ] seq* [ "" concat-as ] action ;
-
-: timezone-parser ( -- parser )
- "Z" token
- "-" token
- decdigit 2 exactly-n ":" token
- decdigit 2 exactly-n 4seq [ "" concat-as ] action
- 2choice ;
-
-: datetime-parser ( -- parser )
- [
- date-parser ,
- "T" token " " token 2choice ,
- time-parser ,
- timezone-parser optional ,
- ] seq* [ "" concat-as ] action ;
-
-: space ( -- parser )
- [ " \t" member? ] satisfy repeat0 ;
-
-: whitespace ( -- parser )
- [ " \t\r\n" member? ] satisfy repeat0 ;
-
-DEFER: value-parser
-
-: array-parser ( -- parser )
- [
- "[" token hide ,
- whitespace hide ,
- value-parser
- whitespace "," token whitespace pack list-of ,
- whitespace hide ,
- "]" token hide ,
- ] seq* [ first { } like ] action ;
-
-DEFER: key-value-parser
-
-DEFER: update-toml
-
-: inline-table-parser ( -- parser )
- [
- "{" token hide ,
- whitespace hide ,
- key-value-parser
- whitespace "," token whitespace pack list-of ,
- whitespace hide ,
- "}" token hide ,
- ] seq* [
- first [ length <hashtable> ] keep [ update-toml ] each
- ] action ;
-
-: value-parser ( -- parser )
- [
- [
- boolean-parser ,
- datetime-parser ,
- date-parser ,
- time-parser ,
- float-parser ,
- integer-parser ,
- string-parser ,
- array-parser ,
- inline-table-parser ,
- ] choice*
- ] delay ;
-
-: name-parser ( -- parser )
- [
- CHAR: A CHAR: Z range ,
- CHAR: a CHAR: z range ,
- CHAR: 0 CHAR: 9 range ,
- "_" token [ first ] action ,
- "-" token [ first ] action ,
- ] choice* repeat1 [ "" like ] action single-string 2choice ;
-
-: comment-parser ( -- parser )
- [
- space hide ,
- "#" token ,
- [ CHAR: \n = not ] satisfy repeat0 ,
- ] seq* [ drop f ] action ;
-
-: key-parser ( -- parser )
- name-parser "." token list-of [ { } like ] action ;
-
-: key-value-parser ( -- parser )
- [
- space hide ,
- key-parser ,
- space hide ,
- "=" token hide ,
- space hide ,
- value-parser ,
- comment-parser optional hide ,
- ] seq* [ first2 entry boa ] action ;
-
-: line-parser ( -- parser )
- "\n" token "\r\n" token 2choice ;
-
-:: table-name-parser ( begin end -- parser )
- [
- begin token hide ,
- space hide ,
- name-parser
- space "." token space pack list-of
- [ { } like ] action ,
- space hide ,
- end token hide ,
- comment-parser optional hide ,
- ] seq* ;
-
-: table-parser ( -- parser )
- [
- space hide ,
- "[[" "]]" table-name-parser [ t suffix! ] action
- "[" "]" table-name-parser [ f suffix! ] action
- 2choice ,
- whitespace hide ,
- key-value-parser line-parser list-of optional ,
- ] seq* [ first2 [ first2 ] dip table boa ] action ;
-
-: toml-parser ( -- parser )
- [
- whitespace hide ,
- [
- comment-parser ,
- table-parser ,
- key-value-parser ,
- ] choice* whitespace list-of ,
- whitespace hide ,
- ] seq* [ first sift { } like ] action ;
-
-: check-no-key ( key assoc -- key assoc )
- 2dup at* nip [ over duplicate-key ] when ;
-
-: deep-at ( keys assoc -- value )
- swap [
- over ?at [ nip ] [
- H{ } clone [ swap rot check-no-key set-at ] keep
- ] if
- ] each ;
-
-GENERIC: update-toml ( assoc entry -- assoc )
-
-M: entry update-toml
- [ key>> unclip-last [ over deep-at ] dip ] [ value>> ] bi
- swap rot check-no-key set-at ;
-
-M: table update-toml
- [ name>> unclip-last [ over deep-at ] dip ]
- [ entries>> [ H{ } clone ] dip [ update-toml ] each swap rot ]
- [ array?>> [ push-at ] [ check-no-key set-at ] if ] tri ;
-
-PRIVATE>
-
-: toml> ( string -- assoc )
- [ H{ } clone ] dip toml-parser parse [ update-toml ] each ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-Support for uuencoding and uudecoding.
+++ /dev/null
-USING: kernel tools.test uu ;
-IN: uu.tests
-
-CONSTANT: plain
-"The smooth-scaled python crept over the sleeping dog"
-
-CONSTANT: encoded
-"begin
-M5&AE('-M;V]T:\"US8V%L960@<'ET:&]N(&-R97!T(&]V97(@=&AE('-L965P
-':6YG(&1O9P
-end
-"
-
-{ t } [ plain string>uu encoded = ] unit-test
-{ t } [ encoded uu>string plain = ] unit-test
-
-{ "Cat" } [
- "begin 644 cat.txt\n#0V%T\n`\nend\n" uu>string
-] unit-test
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: io io.streams.string kernel locals make math math.bitwise
-math.order namespaces sequences ;
-
-IN: uu
-
-<PRIVATE
-
-ERROR: bad-length seq ;
-
-: check-length ( seq -- seq )
- dup length 45 > [ bad-length ] when ; inline
-
-:: binary>ascii ( seq -- seq' )
- 0 :> char!
- 0 :> bits!
- seq check-length [
- dup length CHAR: \s + ,
-
- [ dup empty? bits zero? and ] [
-
- char 8 shift char!
- bits 8 + bits!
-
- dup empty? [
- unclip-slice char bitor char!
- ] unless
-
- [ bits 6 >= ] [
- bits 6 -
- [ char swap neg shift 0x3f bitand CHAR: \s + , ]
- [ bits! ] bi
- ] while
-
- ] until drop
- ] "" make ;
-
-ERROR: illegal-character ch ;
-
-: check-illegal-character ( ch -- ch )
- dup CHAR: \s dup 64 + between? [ illegal-character ] unless ;
-
-:: ascii>binary ( seq -- seq' )
- 0 :> char!
- 0 :> bits!
-
- seq unclip-slice CHAR: \s - :> len!
-
- [
- [ dup empty? not len 0 > and ] [
- dup empty? [ 0 ] [ unclip-slice ] if
- dup "\r\n\0" member? [
- drop 0
- ] [
- check-illegal-character
- CHAR: \s -
- ] if
-
- char 6 shift bitor char!
- bits 6 + bits!
-
- bits 8 >= [
- bits 8 -
- [ char swap neg shift 0xff bitand , ]
- [ on-bits char bitand char! ]
- [ bits! ] tri
- len 1 - len!
- ] when
- ] while drop
-
- ] "" make ;
-
-PRIVATE>
-
-: uu-encode ( -- )
- "begin" print
- input-stream get [ binary>ascii print ] 45 (each-stream-block)
- "end" print ;
-
-: string>uu ( seq -- seq' )
- [ [ uu-encode ] with-string-writer ] with-string-reader ;
-
-: uu-decode ( -- )
- [ [ "begin" head? ] [ not ] bi or ] [ readln ] do until
- [
- dup [ "end" head? ] [ not ] bi or
- [ drop t ] [ ascii>binary write f ] if
- ] [ readln ] do until ;
-
-: uu>string ( seq -- seq )
- [ [ uu-decode ] with-string-writer ] with-string-reader ;
projects / factor.git / commitdiff