├── .gitignore ├── .travis.yml ├── Changes ├── LICENSE ├── META6.json ├── README.md ├── lib └── JSON │ └── Fast.pm6 ├── t ├── 01-parse.t ├── 02-structure.t ├── 03-unicode.t ├── 04-roundtrip.t ├── 05-unreasonable-requirements.t ├── 06-control-characters.t ├── 07-datetime.t ├── 08-sorted-keys.t ├── 09-race.t ├── 10-multidocument.t ├── 11-enum.t ├── 12-assocpositional.t ├── 13-scopes.t └── 14-comments.t └── xt └── meta.t /.gitignore: -------------------------------------------------------------------------------- 1 | .precomp 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | sudo: false 3 | perl6: 4 | - latest 5 | install: 6 | - rakudobrew build-zef 7 | - zef install --force --/test Test::META 8 | - zef install --depsonly . 9 | script: 10 | - zef test . 11 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for JSON-Fast 2 | 3 | {{$NEXT}} 4 | 5 | 0.19 2023-04-30T22:38:25+02:00 6 | - Allow Callable with :sorted-keys argument 7 | 8 | 0.18 2023-04-30T21:48:05+02:00 9 | - Add support for JSONC (aka JSON with C-style comments) 10 | 11 | 0.17 2022-02-10T18:40:34+01:00 12 | - Add :immutable parameter to "from-json" 13 | - Document :enums-as-value parameter to "to-json" 14 | - Allow for changing default values in use statement 15 | 16 | 0.16 2021-05-29T23:57:47+02:00 17 | - Jsonify FatRat objects as floating point numbers 18 | 19 | 0.15 2020-08-13T18:43:26+02:00 20 | - When both match, prefer Associative over Positional 21 | 22 | 0.14 2020-07-26T23:55:00+02:00 23 | - Make sure hash keys are escaped again 24 | 25 | 0.13 2020-07-21T00:28:54+02:00 26 | - Include lizmat's much faster rewrite of parsing code, about 4.4x as fast 27 | - Reword some error messages 28 | 29 | 0.12 2020-07-08T21:03:47+02:00 30 | - Make sure object-keyed hashes stringify keys 31 | 32 | 0.11 2020-07-08T20:38:47+02:00 33 | - Fix rejecting valid escape sequences sometimes 34 | - Fix escaping \f and \b 35 | 36 | 0.10 2019-08-30T16:47:12+02:00 37 | - Enums now consistently jsonify as their keys 38 | - Add :enums-as-values to override enum jsonification 39 | to give values instead of keys. 40 | 41 | 0.9.18 2019-07-02T03:05:24+02:00 42 | - More significant improvement of to-json speed 43 | 44 | 0.9.17 2019-07-02T02:47:36+02:00 45 | - Slight improvement of to-json speed 46 | 47 | 0.9.16 2019-07-01T19:18:14+02:00 48 | - :!pretty now promises only a single line of output. 49 | 50 | 0.9.15 2019-07-01T00:34:29+02:00 51 | - Enums jsonify as a string of their short name again. 52 | 53 | 0.9.14 2019-06-27T01:51:50+02:00 54 | - Nonpretty output doesn't need a space between keys and values 55 | - Unexpected extra data after parse now gives a structured exception 56 | including the parsed data so far, and the position parsing ended, 57 | so that multiple documents in a file can be parsed just fine. 58 | 59 | 0.9.13 2019-06-07T20:54:16+02:00 60 | - Fix pretty output for empty arrays/hashes 61 | - Include lizmat's much faster to-json implementation 62 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2015 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | 203 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "auth": "cpan:TIMOTIMO", 3 | "authors": [ 4 | "Timo Paulssen", 5 | "Tony O'Dell", 6 | "Wenzel P. P. Peppmeyer", 7 | "Elizabeth Mattijsen" 8 | ], 9 | "build-depends": [ 10 | ], 11 | "depends": [ 12 | ], 13 | "description": "A naive, fast json parser and serializer; drop-in replacement for JSON::Tiny", 14 | "license": "Artistic-2.0", 15 | "meta6": "0", 16 | "name": "JSON::Fast", 17 | "perl": "6.*", 18 | "provides": { 19 | "JSON::Fast": "lib/JSON/Fast.pm6" 20 | }, 21 | "resources": [ 22 | ], 23 | "source-url": "git://github.com/timo/json_fast.git", 24 | "support": { 25 | "source": "git://github.com/timo/json_fast.git" 26 | }, 27 | "tags": [ 28 | ], 29 | "test-depends": [ 30 | "Test" 31 | ], 32 | "version": "0.19" 33 | } 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/timo/json_fast.svg?branch=master)](https://travis-ci.org/timo/json_fast) 2 | 3 | JSON::Fast 4 | ========== 5 | 6 | A naive imperative JSON parser in pure Raku (but with direct access to `nqp::` ops), to evaluate performance against `JSON::Tiny`. It is a drop-in replacement for `JSON::Tiny`’s from-json and to-json subs, but it offers a few extra features. 7 | 8 | Currently it seems to be about 4x faster and uses up about a quarter of the RAM JSON::Tiny would use. 9 | 10 | This module also includes a very fast to-json function that tony-o created and lizmat later completely refactored. 11 | 12 | SYNOPSIS 13 | -------- 14 | 15 | use JSON::Fast; 16 | my $storage-path = $*SPEC.tmpdir.child("json-fast-example-$*PID.json"); 17 | say "using path $storage-path for example"; 18 | for -> $word { 19 | say "- loading json file"; 20 | my $current-data = from-json ($storage-path.IO.slurp // "\{}"); 21 | # $current-data now contains a Hash object populated with what was in the file 22 | # (or an empty hash in the very first step when the file didn't exsit yet) 23 | 24 | say "- adding entry for $word"; 25 | $current-data{$word}{"length"} = $word.chars; 26 | $current-data{$word}{"first letter"} = $word.substr(0,1); 27 | 28 | say "- saving json file"; 29 | $storage-path.IO.spurt(to-json $current-data); 30 | # to-json gives us a regular string, so we can plop that 31 | # into the file with the spurt method 32 | 33 | say "json file is now $storage-path.IO.s() bytes big"; 34 | say "==="; 35 | } 36 | say "here is the entire contents of the json file:"; 37 | say "===="; 38 | say $storage-path.IO.slurp(); 39 | say "===="; 40 | say "deleting storage file ..."; 41 | $storage-path.IO.unlink; 42 | 43 | Exported subroutines 44 | -------------------- 45 | 46 | ### to-json 47 | 48 | my $*JSON_NAN_INF_SUPPORT = 1; # allow NaN, Inf, and -Inf to be serialized. 49 | say to-json []; 50 | say to-json [], :!pretty; 51 | say to-json [], :spacing(4); 52 | 53 | enum Blerp ; 54 | say to-json [Hello, Goodbye]; # ["Hello", "Goodbye"] 55 | say to-json [Hello, Goodbye], :enums-as-value; # [0, 1] 56 | 57 | Encode a Raku data structure into JSON. Takes one positional argument, which is a thing you want to encode into JSON. Takes these optional named arguments: 58 | 59 | #### pretty 60 | 61 | `Bool`. Defaults to `True`. Specifies whether the output should be "pretty", human-readable JSON. When set to `False`, will output json in a single line. 62 | 63 | #### spacing 64 | 65 | `Int`. Defaults to `2`. Applies only when `pretty` is `True`. Controls how much spacing there is between each nested level of the output. 66 | 67 | #### sorted-keys 68 | 69 | Specifies whether keys from objects should be sorted before serializing them to a string or if `$obj.keys` is good enough. Defaults to `False`. Can also be specified as a `Callable` with the same type of argument that the `.sort` method accepts to provide alternate sorting methods. 70 | 71 | #### enum-as-value 72 | 73 | `Bool`, defaults to `False`. Specifies whether `enum`s should be json-ified as their underlying values, instead of as the name of the `enum`. 74 | 75 | ### from-json 76 | 77 | my $x = from-json '["foo", "bar", {"ber": "bor"}]'; 78 | say $x.perl; 79 | # outputs: $["foo", "bar", {:ber("bor")}] 80 | 81 | Takes one positional argument that is coerced into a `Str` type and represents a JSON text to decode. Returns a Raku datastructure representing that JSON. 82 | 83 | #### immutable 84 | 85 | `Bool`. Defaults to `False`. Specifies whether `Hash`es and `Array`s should be rendered as immutable datastructures instead (as `Map` / `List`. Creating an immutable data structures is mostly saving on memory usage, and a little bit on CPU (typically around 5%). 86 | 87 | This also has the side effect that elements from the returned structure can now be iterated over directly because they are not containerized. 88 | 89 | my %hash := from-json "META6.json".IO.slurp, :immutable; 90 | say "Provides:"; 91 | .say for %hash; 92 | 93 | #### allow-jsonc 94 | 95 | `Bool`. Defaults to `False`. Specifies whether commmands adhering to the [JSONC standard](https://changelog.com/news/jsonc-is-a-superset-of-json-which-supports-comments-6LwR) are allowed. 96 | 97 | Additional features 98 | ------------------- 99 | 100 | ### Adapting defaults of "from-json" 101 | 102 | In the `use` statement, you can add the string `"immutable"` to make the default of the `immutable` parameter to the `from-json` subroutine `True`, rather than `False`. 103 | 104 | use JSON::Fast ; # create immutable data structures by default 105 | 106 | ### Adapting defaults of "to-json" 107 | 108 | In the `use` statement, you can add the strings `"!pretty"`, `"sorted-keys"` and/or `"enums-as-value"` to change the associated defaults of the `to-json` subroutine. 109 | 110 | use JSON::FAST ; 111 | 112 | ### Strings containing multiple json pieces 113 | 114 | When the document contains additional non-whitespace after the first successfully parsed JSON object, JSON::Fast will throw the exception `X::JSON::AdditionalContent`. If you expect multiple objects, you can catch that exception, retrieve the parse result from its `parsed` attribute, and remove the first `rest-position` characters off of the string and restart parsing from there. 115 | 116 | -------------------------------------------------------------------------------- /lib/JSON/Fast.pm6: -------------------------------------------------------------------------------- 1 | =begin pod 2 | =head1 JSON::Fast 3 | 4 | A naive imperative JSON parser in pure Raku (but with direct access to C ops), to evaluate performance against C. It is a drop-in replacement for C’s from-json and to-json subs, but it offers a few extra features. 5 | 6 | Currently it seems to be about 4x faster and uses up about a quarter of the RAM JSON::Tiny would use. 7 | 8 | This module also includes a very fast to-json function that tony-o created and lizmat later completely refactored. 9 | 10 | =head2 SYNOPSIS 11 | 12 | =begin code 13 | use JSON::Fast; 14 | my $storage-path = $*SPEC.tmpdir.child("json-fast-example-$*PID.json"); 15 | say "using path $storage-path for example"; 16 | for -> $word { 17 | say "- loading json file"; 18 | my $current-data = from-json ($storage-path.IO.slurp // "\{}"); 19 | # $current-data now contains a Hash object populated with what was in the file 20 | # (or an empty hash in the very first step when the file didn't exsit yet) 21 | 22 | say "- adding entry for $word"; 23 | $current-data{$word}{"length"} = $word.chars; 24 | $current-data{$word}{"first letter"} = $word.substr(0,1); 25 | 26 | say "- saving json file"; 27 | $storage-path.IO.spurt(to-json $current-data); 28 | # to-json gives us a regular string, so we can plop that 29 | # into the file with the spurt method 30 | 31 | say "json file is now $storage-path.IO.s() bytes big"; 32 | say "==="; 33 | } 34 | say "here is the entire contents of the json file:"; 35 | say "===="; 36 | say $storage-path.IO.slurp(); 37 | say "===="; 38 | say "deleting storage file ..."; 39 | $storage-path.IO.unlink; 40 | =end code 41 | 42 | =head2 Exported subroutines 43 | 44 | =head3 to-json 45 | 46 | =for code 47 | my $*JSON_NAN_INF_SUPPORT = 1; # allow NaN, Inf, and -Inf to be serialized. 48 | say to-json []; 49 | say to-json [], :!pretty; 50 | say to-json [], :spacing(4); 51 | 52 | =for code 53 | enum Blerp ; 54 | say to-json [Hello, Goodbye]; # ["Hello", "Goodbye"] 55 | say to-json [Hello, Goodbye], :enums-as-value; # [0, 1] 56 | 57 | Encode a Raku data structure into JSON. Takes one positional argument, which 58 | is a thing you want to encode into JSON. Takes these optional named arguments: 59 | 60 | =head4 pretty 61 | 62 | C. Defaults to C. Specifies whether the output should be "pretty", 63 | human-readable JSON. When set to C, will output json in a single line. 64 | 65 | =head4 spacing 66 | 67 | C. Defaults to C<2>. Applies only when C is C. 68 | Controls how much spacing there is between each nested level of the output. 69 | 70 | =head4 sorted-keys 71 | 72 | Specifies whether keys from objects should be sorted before serializing them 73 | to a string or if C<$obj.keys> is good enough. Defaults to C. Can 74 | also be specified as a C with the same type of argument that the 75 | C<.sort> method accepts to provide alternate sorting methods. 76 | 77 | =head4 enum-as-value 78 | 79 | C, defaults to C. Specifies whether Cs should be json-ified 80 | as their underlying values, instead of as the name of the C. 81 | 82 | =head3 from-json 83 | 84 | =for code 85 | my $x = from-json '["foo", "bar", {"ber": "bor"}]'; 86 | say $x.perl; 87 | # outputs: $["foo", "bar", {:ber("bor")}] 88 | 89 | Takes one positional argument that is coerced into a C type and represents 90 | a JSON text to decode. Returns a Raku datastructure representing that JSON. 91 | 92 | =head4 immutable 93 | 94 | C. Defaults to C. Specifies whether Ces and Cs should be 95 | rendered as immutable datastructures instead (as C / C. Creating an 96 | immutable data structures is mostly saving on memory usage, and a little bit on 97 | CPU (typically around 5%). 98 | 99 | This also has the side effect that elements from the returned structure can now 100 | be iterated over directly because they are not containerized. 101 | 102 | =for code 103 | my %hash := from-json "META6.json".IO.slurp, :immutable; 104 | say "Provides:"; 105 | .say for %hash; 106 | 107 | =head4 allow-jsonc 108 | 109 | C. Defaults to C. Specifies whether commmands adhering to the 110 | L 111 | are allowed. 112 | 113 | =head2 Additional features 114 | 115 | =head3 Adapting defaults of "from-json" 116 | 117 | In the C statement, you can add the string C<"immutable"> to make the 118 | default of the C parameter to the C subroutine C, 119 | rather than C. 120 | 121 | =for code 122 | use JSON::Fast ; # create immutable data structures by default 123 | 124 | =head3 Adapting defaults of "to-json" 125 | 126 | In the C statement, you can add the strings C<"!pretty">, 127 | C<"sorted-keys"> and/or C<"enums-as-value"> to change the associated 128 | defaults of the C subroutine. 129 | 130 | =for code 131 | use JSON::FAST ; 132 | 133 | =head3 Strings containing multiple json pieces 134 | 135 | When the document contains additional non-whitespace after the first 136 | successfully parsed JSON object, JSON::Fast will throw the exception 137 | C. If you expect multiple objects, you 138 | can catch that exception, retrieve the parse result from its 139 | C attribute, and remove the first C characters 140 | off of the string and restart parsing from there. 141 | 142 | =end pod 143 | 144 | use nqp; 145 | 146 | our class X::JSON::AdditionalContent is Exception is export { 147 | has $.parsed; 148 | has $.parsed-length; 149 | has $.rest-position; 150 | 151 | method message { 152 | "JSON Input contained additional text after the document (parsed $.parsed-length chars, next non-whitespace lives at $.rest-position)" 153 | } 154 | } 155 | 156 | module JSON::Fast:ver<0.19> { 157 | 158 | multi sub to-surrogate-pair(Int $ord) { 159 | my int $base = $ord - 0x10000; 160 | my int $top = $base +& 0b1_1111_1111_1100_0000_0000 +> 10; 161 | my int $bottom = $base +& 0b11_1111_1111; 162 | Q/\u/ ~ (0xD800 + $top).base(16) ~ Q/\u/ ~ (0xDC00 + $bottom).base(16); 163 | } 164 | 165 | multi sub to-surrogate-pair(Str $input) { 166 | to-surrogate-pair(nqp::ordat($input, 0)); 167 | } 168 | 169 | my $tab := nqp::list_i(92,116); # \t 170 | my $lf := nqp::list_i(92,110); # \n 171 | my $cr := nqp::list_i(92,114); # \r 172 | my $qq := nqp::list_i(92, 34); # \" 173 | my $bs := nqp::list_i(92, 92); # \\ 174 | 175 | # Convert string to decomposed codepoints. Run over that integer array 176 | # and inject whatever is necessary, don't do anything if simple ascii. 177 | # Then convert back to string and return that. 178 | sub str-escape(\text) { 179 | my $codes := text.NFD; 180 | my int $i = -1; 181 | 182 | nqp::while( 183 | nqp::islt_i(++$i,nqp::elems($codes)), 184 | nqp::if( 185 | nqp::isle_i((my int $code = nqp::atpos_i($codes,$i)),92) 186 | || nqp::isge_i($code,128), 187 | nqp::if( # not ascii 188 | nqp::isle_i($code,31), 189 | nqp::if( # control 190 | nqp::iseq_i($code,10), 191 | nqp::splice($codes,$lf,$i++,1), # \n 192 | nqp::if( 193 | nqp::iseq_i($code,13), 194 | nqp::splice($codes,$cr,$i++,1), # \r 195 | nqp::if( 196 | nqp::iseq_i($code,9), 197 | nqp::splice($codes,$tab,$i++,1), # \t 198 | nqp::stmts( # other control 199 | nqp::splice($codes,$code.fmt(Q/\u%04x/).NFD,$i,1), 200 | ($i = nqp::add_i($i,5)) 201 | ) 202 | ) 203 | ) 204 | ), 205 | nqp::if( # not control 206 | nqp::iseq_i($code,34), 207 | nqp::splice($codes,$qq,$i++,1), # " 208 | nqp::if( 209 | nqp::iseq_i($code,92), 210 | nqp::splice($codes,$bs,$i++,1), # \ 211 | nqp::if( 212 | nqp::isge_i($code,0x10000), 213 | nqp::stmts( # surrogates 214 | nqp::splice( 215 | $codes, 216 | (my $surrogate := to-surrogate-pair($code.chr).NFD), 217 | $i, 218 | 1 219 | ), 220 | ($i = nqp::sub_i(nqp::add_i($i,nqp::elems($surrogate)),1)) 221 | ) 222 | ) 223 | ) 224 | ) 225 | ) 226 | ) 227 | ); 228 | 229 | nqp::strfromcodes($codes) 230 | } 231 | 232 | our sub to-json( 233 | \obj, 234 | Bool :$pretty = True, 235 | Int :$level = 0, 236 | int :$spacing = 2, 237 | :$sorted-keys = False, 238 | Bool :$enums-as-value = False, 239 | ) { 240 | 241 | my str @out; 242 | my str $spaces = ' ' x $spacing; 243 | my str $comma = ",\n" ~ $spaces x $level; 244 | 245 | #-- helper subs from here, with visibility to the above lexicals 246 | 247 | sub pretty-positional(\positional --> Nil) { 248 | $comma = nqp::concat($comma,$spaces); 249 | nqp::push_s(@out,'['); 250 | nqp::push_s(@out,nqp::substr($comma,1)); 251 | 252 | for positional.list { 253 | jsonify($_); 254 | nqp::push_s(@out,$comma); 255 | } 256 | nqp::pop_s(@out); # lose last comma 257 | 258 | $comma = nqp::substr($comma,0,nqp::sub_i(nqp::chars($comma),$spacing)); 259 | nqp::push_s(@out,nqp::substr($comma,1)); 260 | nqp::push_s(@out,']'); 261 | } 262 | 263 | sub pretty-associative(\associative --> Nil) { 264 | $comma = nqp::concat($comma,$spaces); 265 | nqp::push_s(@out,'{'); 266 | nqp::push_s(@out,nqp::substr($comma,1)); 267 | my \pairs := $sorted-keys 268 | ?? associative.sort($sorted-keys<> =:= True ?? *.key !! $sorted-keys) 269 | !! associative.list; 270 | 271 | for pairs { 272 | nqp::push_s(@out,'"'); 273 | nqp::push_s(@out, str-escape(.key.Str)); 274 | nqp::push_s(@out,'": '); 275 | jsonify(.value); 276 | nqp::push_s(@out,$comma); 277 | } 278 | nqp::pop_s(@out); # lose last comma 279 | 280 | $comma = nqp::substr($comma,0,nqp::sub_i(nqp::chars($comma),$spacing)); 281 | nqp::push_s(@out,nqp::substr($comma,1)); 282 | nqp::push_s(@out,'}'); 283 | } 284 | 285 | sub unpretty-positional(\positional --> Nil) { 286 | nqp::push_s(@out,'['); 287 | my int $before = nqp::elems(@out); 288 | for positional.list { 289 | jsonify($_); 290 | nqp::push_s(@out,","); 291 | } 292 | nqp::pop_s(@out) if nqp::elems(@out) > $before; # lose last comma 293 | nqp::push_s(@out,']'); 294 | } 295 | 296 | sub unpretty-associative(\associative --> Nil) { 297 | nqp::push_s(@out,'{'); 298 | my \pairs := $sorted-keys 299 | ?? associative.sort($sorted-keys<> =:= True ?? *.key !! $sorted-keys) 300 | !! associative.list; 301 | 302 | my int $before = nqp::elems(@out); 303 | for pairs { 304 | nqp::push_s(@out, '"'); 305 | nqp::push_s(@out, str-escape(.key.Str)); 306 | nqp::push_s(@out,'":'); 307 | jsonify(.value); 308 | nqp::push_s(@out,","); 309 | } 310 | nqp::pop_s(@out) if nqp::elems(@out) > $before; # lose last comma 311 | nqp::push_s(@out,'}'); 312 | } 313 | 314 | sub jsonify(\obj --> Nil) { 315 | 316 | with obj { 317 | 318 | # basic ones 319 | if nqp::istype($_, Bool) { 320 | nqp::push_s(@out,obj ?? "true" !! "false"); 321 | } 322 | elsif nqp::istype($_, IntStr) { 323 | jsonify(.Int); 324 | } 325 | elsif nqp::istype($_, RatStr) { 326 | jsonify(.Rat); 327 | } 328 | elsif nqp::istype($_, NumStr) { 329 | jsonify(.Num); 330 | } 331 | elsif nqp::istype($_, Enumeration) { 332 | if $enums-as-value { 333 | jsonify(.value); 334 | } 335 | else { 336 | nqp::push_s(@out,'"'); 337 | nqp::push_s(@out,str-escape(.key)); 338 | nqp::push_s(@out,'"'); 339 | } 340 | } 341 | # Str and Int go below Enumeration, because there 342 | # are both Str-typed enums and Int-typed enums 343 | elsif nqp::istype($_, Str) { 344 | nqp::push_s(@out,'"'); 345 | nqp::push_s(@out,str-escape($_)); 346 | nqp::push_s(@out,'"'); 347 | } 348 | 349 | # numeric ones 350 | elsif nqp::istype($_, Int) { 351 | nqp::push_s(@out,.Str); 352 | } 353 | elsif nqp::istype($_, Rat) { 354 | nqp::push_s(@out,.contains(".") ?? $_ !! "$_.0") 355 | given .Str; 356 | } 357 | elsif nqp::istype($_, FatRat) { 358 | nqp::push_s(@out,.contains(".") ?? $_ !! "$_.0") 359 | given .Str; 360 | } 361 | elsif nqp::istype($_, Rational) { 362 | nqp::push_s(@out,.contains(".") ?? $_ !! "$_.0") 363 | given .Str; 364 | } 365 | elsif nqp::istype($_, Num) { 366 | if nqp::isnanorinf($_) { 367 | nqp::push_s( 368 | @out, 369 | $*JSON_NAN_INF_SUPPORT ?? obj.Str !! "null" 370 | ); 371 | } 372 | else { 373 | nqp::push_s(@out,.contains("e") ?? $_ !! $_ ~ "e0") 374 | given .Str; 375 | } 376 | } 377 | 378 | # iterating ones 379 | elsif nqp::istype($_, Seq) { 380 | jsonify(.cache); 381 | } 382 | elsif nqp::istype($_, Associative) { 383 | $pretty 384 | ?? pretty-associative($_) 385 | !! unpretty-associative($_); 386 | } 387 | elsif nqp::istype($_, Positional) { 388 | $pretty 389 | ?? pretty-positional($_) 390 | !! unpretty-positional($_); 391 | } 392 | 393 | # rarer ones 394 | elsif nqp::istype($_, Dateish) { 395 | nqp::push_s(@out,qq/"$_"/); 396 | } 397 | elsif nqp::istype($_, Instant) { 398 | nqp::push_s(@out,qq/"{.DateTime}"/); 399 | } 400 | elsif nqp::istype($_, Real) { 401 | jsonify(.Bridge); 402 | } 403 | elsif nqp::istype($_, Version) { 404 | jsonify(.Str); 405 | } 406 | 407 | # huh, what? 408 | else { 409 | die "Don't know how to jsonify {.^name}"; 410 | } 411 | } 412 | else { 413 | nqp::push_s(@out,'null'); 414 | } 415 | } 416 | 417 | #-- do the actual work 418 | 419 | jsonify(obj); 420 | nqp::join("",@out) 421 | } 422 | 423 | my $ws := nqp::list_i; 424 | nqp::bindpos_i($ws, 9, 1); # \t 425 | nqp::bindpos_i($ws, 10, 1); # \n 426 | nqp::bindpos_i($ws, 13, 1); # \r 427 | nqp::bindpos_i($ws, 32, 1); # space 428 | nqp::push_i($ws, 0); # allow for -1 as value 429 | 430 | my sub nom-ws(str $text, int $pos is rw --> Nil) { 431 | nqp::while( 432 | nqp::atpos_i($ws, nqp::ordat($text, $pos)), 433 | ++$pos 434 | ); 435 | nqp::if( 436 | nqp::iseq_i(nqp::ordat($text,$pos),47), # / 437 | nom-comment($text,++$pos) 438 | ); 439 | } 440 | 441 | my sub nom-comment(str $text, int $pos is rw --> Nil) { 442 | unless $*ALLOW-JSONC { 443 | --$pos; # un-eat the / 444 | return; 445 | } 446 | 447 | my int $ord; 448 | nqp::if( 449 | nqp::iseq_i(($ord = nqp::ordat($text,$pos)),47), # / 450 | nqp::stmts( 451 | nqp::while( # eating a // style comment 452 | nqp::isne_i(($ord = nqp::ordat($text,++$pos)),10) # not \n 453 | && nqp::isne_i($ord,-1), # not eos 454 | nqp::null 455 | ), 456 | nom-ws($text, $ord == -1 ?? $pos !! ++$pos) 457 | ), 458 | nqp::if( 459 | nqp::iseq_i($ord,42), # * 460 | nqp::stmts( 461 | nqp::until( # eating a /* */ style comment 462 | nqp::iseq_i(($ord = nqp::ordat($text,++$pos)),-1) # eos 463 | || (nqp::iseq_i($ord,47) # / 464 | && nqp::iseq_i( 465 | nqp::ordat($text,nqp::sub_i($pos,1)), 466 | 42 # * 467 | )), 468 | nqp::null 469 | ), 470 | nqp::if( 471 | nqp::iseq_i($ord,-1), 472 | die-end-in-comment($text,$pos), 473 | nom-ws($text, ++$pos) 474 | ) 475 | ), 476 | nqp::if( 477 | nqp::iseq_i($ord,-1), 478 | die-end-in-comment($text,$pos), 479 | die-unexpected-object($text, $pos) 480 | ) 481 | ) 482 | ); 483 | } 484 | 485 | my $hexdigits := nqp::list; 486 | nqp::bindpos($hexdigits, 48, 0); # 0 487 | nqp::bindpos($hexdigits, 49, 1); # 1 488 | nqp::bindpos($hexdigits, 50, 2); # 2 489 | nqp::bindpos($hexdigits, 51, 3); # 3 490 | nqp::bindpos($hexdigits, 52, 4); # 4 491 | nqp::bindpos($hexdigits, 53, 5); # 5 492 | nqp::bindpos($hexdigits, 54, 6); # 6 493 | nqp::bindpos($hexdigits, 55, 7); # 7 494 | nqp::bindpos($hexdigits, 56, 8); # 8 495 | nqp::bindpos($hexdigits, 57, 9); # 9 496 | nqp::bindpos($hexdigits, 65, 10); # A 497 | nqp::bindpos($hexdigits, 66, 11); # B 498 | nqp::bindpos($hexdigits, 67, 12); # C 499 | nqp::bindpos($hexdigits, 68, 13); # D 500 | nqp::bindpos($hexdigits, 69, 14); # E 501 | nqp::bindpos($hexdigits, 70, 15); # F 502 | nqp::bindpos($hexdigits, 97, 10); # a 503 | nqp::bindpos($hexdigits, 98, 11); # b 504 | nqp::bindpos($hexdigits, 99, 12); # c 505 | nqp::bindpos($hexdigits, 100, 13); # d 506 | nqp::bindpos($hexdigits, 101, 14); # e 507 | nqp::bindpos($hexdigits, 102, 15); # f 508 | 509 | my $escapees := nqp::list_i; 510 | nqp::bindpos_i($escapees, 34, 34); # " 511 | nqp::bindpos_i($escapees, 47, 47); # / 512 | nqp::bindpos_i($escapees, 92, 92); # \ 513 | nqp::bindpos_i($escapees, 98, 8); # b 514 | nqp::bindpos_i($escapees, 102, 12); # f 515 | nqp::bindpos_i($escapees, 110, 10); # n 516 | nqp::bindpos_i($escapees, 114, 13); # r 517 | nqp::bindpos_i($escapees, 116, 9); # t 518 | 519 | my sub parse-string(str $text, int $pos is rw) { 520 | nqp::if( 521 | nqp::eqat($text, '"', nqp::sub_i($pos,1)) # starts with clean " 522 | && nqp::eqat($text, '"', # ends with clean " 523 | (my int $end = nqp::findnotcclass(nqp::const::CCLASS_WORD, 524 | $text, $pos, nqp::sub_i(nqp::chars($text),$pos))) 525 | ), 526 | nqp::stmts( 527 | (my $string := nqp::substr($text, $pos, nqp::sub_i($end, $pos))), 528 | ($pos = nqp::add_i($end,1)), 529 | $string 530 | ), 531 | parse-string-slow($text, $pos) 532 | ) 533 | } 534 | 535 | # Slower parsing of string if the string does not exist of 0 or more 536 | # alphanumeric characters 537 | my sub parse-string-slow(str $text, int $pos is rw) { 538 | 539 | my int $start = nqp::sub_i($pos,1); # include starter in string 540 | nqp::until( 541 | nqp::iseq_i((my $end := nqp::index($text, '"', $pos)), -1), 542 | nqp::stmts( 543 | ($pos = $end + 1), 544 | (my int $index = 1), 545 | nqp::while( 546 | nqp::eqat($text, '\\', nqp::sub_i($end, $index)), 547 | ($index = nqp::add_i($index, 1)) 548 | ), 549 | nqp::if( 550 | nqp::bitand_i($index, 1), 551 | (return unjsonify-string( # preceded by an even number of \ 552 | nqp::strtocodes( 553 | nqp::substr($text, $start, $end - $start), 554 | nqp::const::NORMALIZE_NFD, 555 | nqp::create(NFD) 556 | ), 557 | $pos 558 | )) 559 | ) 560 | ) 561 | ); 562 | die "unexpected end of input in string"; 563 | } 564 | 565 | # convert a sequence of Uni elements into a string, with the initial 566 | # quoter as the first element. 567 | my sub unjsonify-string(Uni:D \codes, int $pos) { 568 | nqp::shift_i(codes); # lose the " without any decoration 569 | 570 | # fetch a single codepoint from the next 4 Uni elements 571 | my sub fetch-codepoint() { 572 | my int $codepoint = 0; 573 | my int $times = 5; 574 | 575 | nqp::while( 576 | ($times = nqp::sub_i($times, 1)), 577 | nqp::if( 578 | nqp::elems(codes), 579 | nqp::if( 580 | nqp::iseq_i( 581 | (my uint32 $ordinal = nqp::shift_i(codes)), 582 | 48 # 0 583 | ), 584 | ($codepoint = nqp::mul_i($codepoint, 16)), 585 | nqp::if( 586 | (my int $adder = nqp::atpos($hexdigits, $ordinal)), 587 | ($codepoint = nqp::add_i( 588 | nqp::mul_i($codepoint, 16), 589 | $adder 590 | )), 591 | (die "invalid hexadecimal char { 592 | nqp::chr($ordinal).perl 593 | } in \\u sequence at $pos") 594 | ) 595 | ), 596 | (die "incomplete \\u sequence in string near $pos") 597 | ) 598 | ); 599 | 600 | $codepoint 601 | } 602 | 603 | my $output := nqp::create(Uni); 604 | nqp::while( 605 | nqp::elems(codes), 606 | nqp::if( 607 | nqp::iseq_i( 608 | (my uint32 $ordinal = nqp::shift_i(codes)), 609 | 92 # \ 610 | ), 611 | nqp::if( # haz an escape 612 | nqp::iseq_i(($ordinal = nqp::shift_i(codes)), 117), # u 613 | nqp::stmts( # has a \u escape 614 | nqp::if( 615 | nqp::isge_i((my int $codepoint = fetch-codepoint), 0xD800) 616 | && nqp::islt_i($codepoint, 0xE000), 617 | nqp::if( # high surrogate 618 | nqp::iseq_i(nqp::atpos_i(codes, 0), 92) # \ 619 | && nqp::iseq_i(nqp::atpos_i(codes, 1), 117), # u 620 | nqp::stmts( # low surrogate 621 | nqp::shift_i(codes), # get rid of \ 622 | nqp::shift_i(codes), # get rid of u 623 | nqp::if( 624 | nqp::isge_i((my int $low = fetch-codepoint), 0xDC00), 625 | ($codepoint = nqp::add_i( # got low surrogate 626 | nqp::add_i( # transmogrify 627 | nqp::mul_i(nqp::sub_i($codepoint, 0xD800), 0x400), 628 | 0x10000 # with 629 | ), # low surrogate 630 | nqp::sub_i($low, 0xDC00) 631 | )), 632 | (die "improper low surrogate \\u$low.base(16) for high surrogate \\u$codepoint.base(16) near $pos") 633 | ) 634 | ), 635 | (die "missing low surrogate for high surrogate \\u$codepoint.base(16) near $pos") 636 | ) 637 | ), 638 | nqp::push_i($output, $codepoint) 639 | ), 640 | nqp::if( # other escapes? 641 | ($codepoint = nqp::atpos_i($escapees, $ordinal)), 642 | nqp::push_i($output, $codepoint), # recognized escape 643 | (die "unknown escape code found '\\{ # huh? 644 | nqp::chr($ordinal) 645 | }' found near $pos") 646 | ) 647 | ), 648 | nqp::if( # not an escape 649 | nqp::iseq_i($ordinal, 9) || nqp::iseq_i($ordinal, 10), # \t \n 650 | (die "this kind of whitespace is not allowed in a string: '{ 651 | nqp::chr($ordinal).perl 652 | }' near $pos"), 653 | nqp::push_i($output, $ordinal) # ok codepoint 654 | ) 655 | ) 656 | ); 657 | 658 | nqp::strfromcodes($output) 659 | } 660 | 661 | my sub parse-numeric(str $text, int $pos is rw) { 662 | my int $start = nqp::sub_i($pos,1); 663 | 664 | my int $end = nqp::findnotcclass(nqp::const::CCLASS_NUMERIC, 665 | $text, $pos, nqp::sub_i(nqp::chars($text),$pos)); 666 | nqp::if( 667 | nqp::iseq_i(nqp::ordat($text, $end), 46), # . 668 | nqp::stmts( 669 | ($pos = nqp::add_i($end,1)), 670 | ($end = nqp::findnotcclass(nqp::const::CCLASS_NUMERIC, 671 | $text, $pos, nqp::sub_i(nqp::chars($text),$pos)) 672 | ) 673 | ) 674 | ); 675 | 676 | nqp::if( 677 | nqp::iseq_i((my int $ordinal = nqp::ordat($text, $end)), 101) # e 678 | || nqp::iseq_i($ordinal, 69), # E 679 | nqp::stmts( 680 | ($pos = nqp::add_i($end,1)), 681 | ($pos = nqp::add_i($pos, 682 | nqp::eqat($text, '-', $pos) || nqp::eqat($text, '+', $pos) 683 | )), 684 | ($end = nqp::findnotcclass(nqp::const::CCLASS_NUMERIC, 685 | $text, $pos, nqp::sub_i(nqp::chars($text),$pos)) 686 | ) 687 | ) 688 | ); 689 | 690 | my $result := nqp::substr($text, $start, nqp::sub_i($end,$start)).Numeric; 691 | nqp::if( 692 | nqp::istype($result, Failure), 693 | nqp::stmts( 694 | $result.Bool, # handle Failure 695 | (die "at $pos: invalid number token $text.substr($start,$end - $start)") 696 | ), 697 | nqp::stmts( 698 | ($pos = $end), 699 | $result 700 | ) 701 | ) 702 | } 703 | 704 | my sub die-end-in-comment(str $text, int $pos) is hidden-from-backtrace { 705 | die "reached end of input inside comment"; 706 | } 707 | 708 | my sub die-missing-object-key(str $text, int $pos) is hidden-from-backtrace { 709 | die $pos == nqp::chars($text) 710 | ?? "at end of input: expected a quoted string for an object key" 711 | !! "at $pos: json requires object keys to be strings"; 712 | } 713 | 714 | my sub die-unexpected-partitioner(str $text, int $pos) is hidden-from-backtrace { 715 | die "at $pos, unexpected partitioner '{ 716 | nqp::substr($text,$pos,1) 717 | }' inside list of things in an array"; 718 | } 719 | 720 | my sub die-missing-colon(str $text, int $pos) is hidden-from-backtrace { 721 | die "expected to see a ':' after an object key at $pos"; 722 | } 723 | 724 | my sub die-unexpected-end-of-object(str $text, int $pos) is hidden-from-backtrace { 725 | die $pos == nqp::chars($text) 726 | ?? "at end of input: unexpected end of object." 727 | !! "unexpected '{ nqp::substr($text, $pos, 1) }' in an object at $pos"; 728 | } 729 | 730 | my sub die-unexpected-object(str $text, int $pos) is hidden-from-backtrace { 731 | die "at $pos: expected a json object, but got '{ 732 | nqp::substr($text, $pos, 8).perl 733 | }'"; 734 | } 735 | 736 | my sub parse-obj(str $text, int $pos is rw) { 737 | my %result; 738 | my $hash := nqp::ifnull( 739 | nqp::getattr(%result,Map,'$!storage'), 740 | nqp::bindattr(%result,Map,'$!storage',nqp::hash) 741 | ); 742 | 743 | nom-ws($text, $pos); 744 | my int $ordinal = nqp::ordat($text, $pos); 745 | nqp::if( 746 | nqp::iseq_i($ordinal, 125), # } { 747 | nqp::stmts( 748 | ($pos = nqp::add_i($pos,1)), 749 | %result 750 | ), 751 | nqp::stmts( 752 | my $descriptor := nqp::getattr(%result,Hash,'$!descriptor'); 753 | nqp::stmts( # this level is needed for some reason 754 | nqp::while( 755 | 1, 756 | nqp::stmts( 757 | nqp::if( 758 | nqp::iseq_i($ordinal, 34), # " 759 | (my $key := parse-string($text, $pos = nqp::add_i($pos,1))), 760 | die-missing-object-key($text, $pos) 761 | ), 762 | nom-ws($text, $pos), 763 | nqp::if( 764 | nqp::iseq_i(nqp::ordat($text, $pos), 58), # : 765 | ($pos = nqp::add_i($pos, 1)), 766 | die-missing-colon($text, $pos) 767 | ), 768 | nom-ws($text, $pos), 769 | nqp::bindkey($hash, $key, 770 | nqp::p6scalarwithvalue($descriptor, parse-thing($text, $pos))), 771 | nom-ws($text, $pos), 772 | ($ordinal = nqp::ordat($text, $pos)), 773 | nqp::if( 774 | nqp::iseq_i($ordinal, 125), # } { 775 | nqp::stmts( 776 | ($pos = nqp::add_i($pos,1)), 777 | (return %result) 778 | ), 779 | nqp::unless( 780 | nqp::iseq_i($ordinal, 44), # , 781 | die-unexpected-end-of-object($text, $pos) 782 | ) 783 | ), 784 | nom-ws($text, $pos = nqp::add_i($pos,1)), 785 | ($ordinal = nqp::ordat($text, $pos)), 786 | ) 787 | ) 788 | ) 789 | ) 790 | ) 791 | } 792 | 793 | my sub parse-array(str $text, int $pos is rw) { 794 | my @result; 795 | nqp::bindattr(@result, List, '$!reified', 796 | my $buffer := nqp::create(IterationBuffer)); 797 | 798 | nom-ws($text, $pos); 799 | nqp::if( 800 | nqp::eqat($text, ']', $pos), 801 | nqp::stmts( 802 | ($pos = nqp::add_i($pos,1)), 803 | @result 804 | ), 805 | nqp::stmts( 806 | (my $descriptor := nqp::getattr(@result, Array, '$!descriptor')), 807 | nqp::while( 808 | 1, 809 | nqp::stmts( 810 | (my $thing := parse-thing($text, $pos)), 811 | nom-ws($text, $pos), 812 | (my int $partitioner = nqp::ordat($text, $pos)), 813 | nqp::if( 814 | nqp::iseq_i($partitioner,93), # ] 815 | nqp::stmts( 816 | nqp::push($buffer,nqp::p6scalarwithvalue($descriptor,$thing)), 817 | ($pos = nqp::add_i($pos,1)), 818 | (return @result) 819 | ), 820 | nqp::if( 821 | nqp::iseq_i($partitioner,44), # , 822 | nqp::stmts( 823 | nqp::push($buffer,nqp::p6scalarwithvalue($descriptor,$thing)), 824 | ($pos = nqp::add_i($pos,1)) 825 | ), 826 | die-unexpected-partitioner($text, $pos) 827 | ) 828 | ) 829 | ) 830 | ) 831 | ) 832 | ) 833 | } 834 | 835 | my sub parse-true( int $pos is rw --> True) { $pos = $pos + 4 } 836 | my sub parse-false(int $pos is rw --> False) { $pos = $pos + 5 } 837 | my sub parse-null( int $pos is rw) { $pos = $pos + 4; Any } 838 | 839 | my sub parse-thing(str $text, int $pos is rw) { 840 | nom-ws($text, $pos); 841 | my int $ordinal = nqp::ordat($text, $pos); 842 | 843 | nqp::iseq_i($ordinal,34) # " 844 | ?? parse-string($text, $pos = $pos + 1) 845 | !! nqp::iseq_i($ordinal,91) # [ 846 | ?? parse-array($text, $pos = $pos + 1) 847 | !! nqp::iseq_i($ordinal,123) # { 848 | ?? parse-obj($text, $pos = $pos + 1) 849 | !! nqp::iscclass(nqp::const::CCLASS_NUMERIC, $text, $pos) 850 | || nqp::iseq_i($ordinal,45) # - 851 | ?? parse-numeric($text, $pos = $pos + 1) 852 | !! nqp::iseq_i($ordinal,116) && nqp::eqat($text,'true',$pos) 853 | ?? parse-true($pos) 854 | !! nqp::iseq_i($ordinal,102) && nqp::eqat($text,'false',$pos) 855 | ?? parse-false($pos) 856 | !! nqp::iseq_i($ordinal,110) && nqp::eqat($text,'null',$pos) 857 | ?? parse-null($pos) 858 | !! die-unexpected-object($text, $pos) 859 | } 860 | 861 | # Needed so that subroutines can return native hashes without them 862 | # getting upgraded to Hash. The equivalent of IterationBuffer but 863 | # then for Associatives. 864 | my class IterationMap is repr("VMHash") { } 865 | 866 | # Since we create immutable structures, we can have all of the empty 867 | # hashes and arrays refer to the same empty Map and empty List. 868 | my $emptyMap := Map.new; 869 | my $emptyList := List.new; 870 | 871 | my sub hllize-map(\the-map) is raw { 872 | nqp::elems(the-map) 873 | ?? nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',the-map) 874 | !! $emptyMap 875 | } 876 | 877 | my sub hllize-list(\the-list) is raw { 878 | nqp::elems(the-list) 879 | ?? nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',the-list) 880 | !! $emptyList 881 | } 882 | 883 | my sub parse-obj-immutable(str $text, int $pos is rw) { 884 | my $map := nqp::create(IterationMap); 885 | 886 | nom-ws($text, $pos); 887 | my int $ordinal = nqp::ordat($text, $pos); 888 | nqp::if( 889 | nqp::iseq_i($ordinal, 125), # } { 890 | nqp::stmts( 891 | ($pos = nqp::add_i($pos,1)), 892 | hllize-map($map) 893 | ), 894 | nqp::stmts( # this level is needed for some reason 895 | nqp::while( 896 | 1, 897 | nqp::stmts( 898 | nqp::if( 899 | nqp::iseq_i($ordinal, 34), # " 900 | (my $key := parse-string($text, $pos = nqp::add_i($pos,1))), 901 | die-missing-object-key($text, $pos) 902 | ), 903 | nom-ws($text, $pos), 904 | nqp::if( 905 | nqp::iseq_i(nqp::ordat($text, $pos), 58), # : 906 | ($pos = nqp::add_i($pos, 1)), 907 | die-missing-colon($text, $pos) 908 | ), 909 | nom-ws($text, $pos), 910 | nqp::bindkey($map, $key,parse-thing-immutable($text, $pos)), 911 | nom-ws($text, $pos), 912 | ($ordinal = nqp::ordat($text, $pos)), 913 | nqp::if( 914 | nqp::iseq_i($ordinal, 125), # } { 915 | nqp::stmts( 916 | ($pos = nqp::add_i($pos,1)), 917 | (return hllize-map($map)) 918 | ), 919 | nqp::unless( 920 | nqp::iseq_i($ordinal, 44), # , 921 | die-unexpected-end-of-object($text, $pos) 922 | ) 923 | ), 924 | nom-ws($text, $pos = nqp::add_i($pos,1)), 925 | ($ordinal = nqp::ordat($text, $pos)), 926 | ) 927 | ) 928 | ) 929 | ) 930 | } 931 | 932 | my sub parse-array-immutable(str $text, int $pos is rw) { 933 | my $list := nqp::create(IterationBuffer); 934 | 935 | nom-ws($text, $pos); 936 | nqp::if( 937 | nqp::eqat($text, ']', $pos), 938 | nqp::stmts( 939 | ($pos = nqp::add_i($pos,1)), 940 | hllize-list($list) 941 | ), 942 | nqp::stmts( # this level is needed for some reason 943 | nqp::while( 944 | 1, 945 | nqp::stmts( 946 | (my $thing := parse-thing-immutable($text, $pos)), 947 | nom-ws($text, $pos), 948 | (my int $partitioner = nqp::ordat($text, $pos)), 949 | nqp::if( 950 | nqp::iseq_i($partitioner,93), # ] 951 | nqp::stmts( 952 | nqp::push($list, $thing), 953 | ($pos = nqp::add_i($pos,1)), 954 | (return hllize-list($list)) 955 | ), 956 | nqp::if( 957 | nqp::iseq_i($partitioner,44), # , 958 | nqp::stmts( 959 | nqp::push($list, $thing), 960 | ($pos = nqp::add_i($pos,1)) 961 | ), 962 | die-unexpected-partitioner($text, $pos) 963 | ) 964 | ) 965 | ) 966 | ) 967 | ) 968 | ) 969 | } 970 | 971 | my sub parse-thing-immutable(str $text, int $pos is rw) { 972 | nom-ws($text, $pos); 973 | my int $ordinal = nqp::ordat($text, $pos); 974 | 975 | nqp::iseq_i($ordinal,34) # " 976 | ?? parse-string($text, $pos = $pos + 1) 977 | !! nqp::iseq_i($ordinal,91) # [ 978 | ?? parse-array-immutable($text, $pos = $pos + 1) 979 | !! nqp::iseq_i($ordinal,123) # { 980 | ?? parse-obj-immutable($text, $pos = $pos + 1) 981 | !! nqp::iscclass(nqp::const::CCLASS_NUMERIC, $text, $pos) 982 | || nqp::iseq_i($ordinal,45) # - 983 | ?? parse-numeric($text, $pos = $pos + 1) 984 | !! nqp::iseq_i($ordinal,116) && nqp::eqat($text,'true',$pos) 985 | ?? parse-true($pos) 986 | !! nqp::iseq_i($ordinal,102) && nqp::eqat($text,'false',$pos) 987 | ?? parse-false($pos) 988 | !! nqp::iseq_i($ordinal,110) && nqp::eqat($text,'null',$pos) 989 | ?? parse-null($pos) 990 | !! die-unexpected-object($text, $pos) 991 | } 992 | 993 | my sub may-die-additional-content($parsed, str $text, int $pos is rw) is hidden-from-backtrace { 994 | my int $parsed-length = $pos; 995 | try nom-ws($text, $pos); 996 | 997 | X::JSON::AdditionalContent.new( 998 | :$parsed, :$parsed-length, rest-position => $pos 999 | ).throw unless nqp::iseq_i($pos,nqp::chars($text)); 1000 | } 1001 | 1002 | our sub from-json(Str() $text, :$immutable, :$allow-jsonc) { 1003 | my int $pos; 1004 | my $*ALLOW-JSONC := $allow-jsonc; 1005 | my $parsed := $immutable 1006 | ?? parse-thing-immutable($text, $pos) 1007 | !! parse-thing($text, $pos); 1008 | 1009 | # not at the end yet? 1010 | may-die-additional-content($parsed, $text, $pos) 1011 | unless nqp::iseq_i($pos,nqp::chars($text)); 1012 | 1013 | $parsed 1014 | } 1015 | } 1016 | 1017 | sub EXPORT(*@_) { 1018 | my @huh; 1019 | 1020 | my $from-json-changed; 1021 | my $immutable-default := False; 1022 | 1023 | my $to-json-changed; 1024 | my $pretty-default := True; 1025 | my $sorted-keys-default := False; 1026 | my $enums-as-value-default := False; 1027 | 1028 | for @_ { 1029 | when "immutable" { 1030 | $immutable-default := True; 1031 | $from-json-changed := True; 1032 | } 1033 | when "!pretty" { 1034 | $pretty-default := False; 1035 | $to-json-changed := True; 1036 | } 1037 | when "sorted-keys" { 1038 | $sorted-keys-default := True; 1039 | $to-json-changed := True; 1040 | } 1041 | when "enums-as-value" { 1042 | $enums-as-value-default := True; 1043 | $to-json-changed := True; 1044 | } 1045 | when "pretty" | "!immutable" | "!sorted-keys" | "!enums-as-value" { 1046 | # no action, these are the defaults 1047 | } 1048 | default { 1049 | @huh.push: $_; 1050 | } 1051 | } 1052 | 1053 | die "Unrecognized strings in -use- statement: @huh[]" 1054 | if @huh; 1055 | 1056 | my sub from-json-changed(Str() $text, 1057 | :$immutable = $immutable-default, 1058 | ) { 1059 | JSON::Fast::from-json($text, :$immutable) 1060 | } 1061 | my sub to-json-changed(\obj, 1062 | :$pretty = $pretty-default, 1063 | :$sorted-keys = $sorted-keys-default, 1064 | :$enums-as-value = $enums-as-value-default, 1065 | ) { 1066 | JSON::Fast::to-json(obj, :$pretty, :$sorted-keys, :$enums-as-value) 1067 | } 1068 | 1069 | Map.new(( 1070 | '&from-json' => $from-json-changed 1071 | ?? &from-json-changed 1072 | !! &JSON::Fast::from-json, 1073 | '&to-json' => $to-json-changed 1074 | ?? &to-json-changed 1075 | !! &JSON::Fast::to-json, 1076 | )) 1077 | } 1078 | 1079 | # vi:syntax=perl6 1080 | -------------------------------------------------------------------------------- /t/02-structure.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use v6; 3 | use lib 'lib'; 4 | use JSON::Fast; 5 | use Test; 6 | 7 | my @t = 8 | '{ "a" : 1 }' => { a => 1 }, 9 | '[]' => [], 10 | '{}' => {}, 11 | '[ "a", "b"]' => [ "a", "b" ], 12 | '[3]' => [3], 13 | '["\b\f\n\r\t"]' => ["\b\f\n\r\t"], 14 | '["\""]' => ['"'], 15 | '[{ "foo" : { "bar" : 3 } }, 78]' => [{ foo => { bar => 3 }}, 78], 16 | '[{ "a" : 3, "b" : 4 }]' => [{ a => 3, b => 4},], 17 | Q<<{ 18 | "glossary": { 19 | "title": "example glossary", 20 | "GlossDiv": { 21 | "title": "S", 22 | "GlossList": { 23 | "GlossEntry": { 24 | "ID": "SGML", 25 | "SortAs": "SGML", 26 | "GlossTerm": "Standard Generalized Markup Language", 27 | "Acronym": "SGML", 28 | "Abbrev": "ISO 8879:1986", 29 | "GlossDef": { 30 | "para": "A meta-markup language, used to create markup languages such as DocBook.", 31 | "GlossSeeAlso": ["GML", "XML"] 32 | }, 33 | "GlossSee": "markup" 34 | } 35 | } 36 | } 37 | } 38 | } 39 | >> => { 40 | "glossary" => { 41 | "title" => "example glossary", 42 | "GlossDiv" => { 43 | "title" => "S", 44 | "GlossList" => { 45 | "GlossEntry" => { 46 | "ID" => "SGML", 47 | "SortAs" => "SGML", 48 | "GlossTerm" => "Standard Generalized Markup Language", 49 | "Acronym" => "SGML", 50 | "Abbrev" => "ISO 8879:1986", 51 | "GlossDef" => { 52 | "para" => "A meta-markup language, used to create markup languages such as DocBook.", 53 | "GlossSeeAlso" => ["GML", "XML"] 54 | }, 55 | "GlossSee" => "markup" 56 | } 57 | } 58 | } 59 | } 60 | }, 61 | ; 62 | plan @t + @t; 63 | 64 | sub decontainerize(\obj) is raw { 65 | if obj ~~ Positional { 66 | @(obj).map({ decontainerize($_) }).List 67 | } 68 | elsif obj ~~ Associative { 69 | Map.new( @(obj).map({ .key => decontainerize(.value) }) ) 70 | } 71 | else { 72 | obj<> 73 | } 74 | } 75 | 76 | for @t -> $p { 77 | my $s := try from-json($p.key); 78 | is-deeply $s, $p.value, 79 | "Correct data structure for «{$p.key.subst(/\n/, '\n', :g)}»"; 80 | 81 | $s := try from-json($p.key, :immutable); 82 | is-deeply $s, decontainerize($p.value), 83 | "Correct data structure for «{$p.key.subst(/\n/, '\n', :g)}»"; 84 | } 85 | 86 | # vim: ft=perl6 87 | -------------------------------------------------------------------------------- /t/03-unicode.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use v6; 3 | use lib 'lib'; 4 | use JSON::Fast; 5 | use Test; 6 | 7 | 8 | my @t = 9 | '{ "a" : "b\u00E5" }' => { 'a' => 'bå' }, 10 | '[ "\u2685" ]' => [ '⚅' ], 11 | '[ "̅hello" ]' => [ "\x[305]hello" ], 12 | '{ "̅hello": "goodbye" }' => { "\x[305]hello" => "goodbye" }, 13 | '[ "\ud83c\udded\ud83c\uddf7" ]' => [ "🇭🇷" ]; 14 | 15 | my @out = 16 | "\{\"a\":\"bå\"}", 17 | '["⚅"]', 18 | '["̅hello"]', 19 | '{"̅hello":"goodbye"}', 20 | '["\uD83C\uDDED\uD83C\uDDF7"]'; 21 | 22 | plan (+@t * 2 + 2 + 2); 23 | my $i = 0; 24 | for @t -> $p { 25 | my $json = from-json($p.key); 26 | is-deeply $json, $p.value, "Correct data structure for «{$p.key}»"; 27 | is to-json($json, :pretty(False)), @out[$i++], 'to-json test'; 28 | } 29 | 30 | my $zalgostring = utf8.new(34,32,205,149,205,136,204,171,205,137,90,204,182,65,204,155,76,204,183,204,159,204,177,71,204,188,205,150,204,157,204,173,205,153,205,141,204,150,205,159,79,204,184,205,153,204,169,204,152,33,204,176,204,178,205,148,204,166,205,150,204,177,204,175,205,161,34).decode('utf8'); 31 | lives-ok { 32 | from-json $zalgostring; 33 | }, "parse a mean zalgo string"; 34 | 35 | is $zalgostring.&from-json.&to-json, $zalgostring, "zalgostring roundtrips"; 36 | 37 | given "\c[QUOTATION MARK] \c[REVERSE SOLIDUS, REVERSE SOLIDUS]u0004 \c[REVERSE SOLIDUS]u00037 \c[REVERSE SOLIDUS, REVERSE SOLIDUS, COMBINING TILDE] \c[QUOTATION MARK]" { 38 | is .&from-json, " \c[REVERSE SOLIDUS]u0004 \x[3]7 \c[REVERSE SOLIDUS, COMBINING TILDE] "; 39 | is .&from-json.&to-json, .self; 40 | } 41 | -------------------------------------------------------------------------------- /t/04-roundtrip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use Test; 3 | use lib 'lib'; 4 | use JSON::Fast; 5 | 6 | my @s = 7 | 'Int' => [ 1 ], 8 | 'Rat' => [ 3.2 ], 9 | 'Str' => [ 'one' ], 10 | 'Str with quote' => [ '"foo"'], 11 | 'Undef' => [ {}, 1 ], 12 | 'other escapes' => [ "\\/\"\b\f\n\r\tfoo\\"], 13 | 'Non-ASCII' => [ 'möp stüff' ], 14 | 'Empty Array' => [ ], 15 | 'Array of Int' => [ 1, 2, 3, 123123123 ], 16 | 'Array of Num' => [ 1.3, 2.8, 32323423.4, 4.0 ], 17 | 'Array of Str' => [ ], 18 | 'Array of Undef' => [ Any, Any ], 19 | 'Int Allomorph' => [ IntStr.new(0, '') ] => [ 0 ], 20 | 'Rat Allomorph' => [ RatStr.new(0.0, '') ] => [0.0], 21 | 'Num Allomorph' => [ NumStr.new(0e0, '') ] => [0e0], 22 | 'Duration' => [ Duration.new(57) ] => [ 5.7e1 ], 23 | 'Rational' => [ Rational[Int,Int].new(3,10) ] => [ 0.3 ], 24 | 'Empty Hash' => {}, 25 | 'Undef Hash Val' => { key => Any }, 26 | 'Hash of Int' => { :one(1), :two(2), :three(3) }, 27 | 'Hash of Num' => { :one-and-some[1], :almost-pie(3.3) }, 28 | 'Hash of Str' => { :one, :two }, 29 | 'Hash of weird Str' => { "Hello\"" => "good\bye" }, 30 | 'Hash: Int keys' => :{ 1 => 1, 2 => 2, 3 => "hi", 4 => "lol" } => ${ "1" => 1, "2" => 2, "3" => "hi", "4" => "lol" }, 31 | 'Array of Stuff' => [ { 'A hash' => 1 }, [], 2], 32 | 'Hash of Stuff' => 33 | { 34 | keyone => [], 35 | keytwo => "A string", 36 | keythree => { "another" => "hash" }, 37 | keyfour => 4, 38 | keyfive => False, 39 | keysix => True, 40 | keyseven => 3.2, 41 | }, 42 | 'Backslashes 1' => [ "\"Hi\".literal newlnie:\nbackslashed n:\\nbackslashed newlnie:\\\nbackslashes and quotes: \\\"" ], 43 | 'URLs' => [ 'http:\/\/www.github.com\/perl6\/nqp\/' ], 44 | ; 45 | 46 | plan @s * 2; 47 | 48 | for @s.kv -> $k, $v { 49 | my $source-data = $v.value ~~ Pair ?? $v.value.key !! $v.value; 50 | my Str $jsonified = to-json( $source-data, :!pretty ); 51 | is $jsonified.lines.elems, 1, ":!pretty jsonified has only a single line"; 52 | my $r = from-json( $jsonified ); 53 | if $v.value ~~ Pair { 54 | is-deeply $r, $v.value.value, $v.key; 55 | } else { 56 | is-deeply $r, $v.value, $v.key; 57 | } 58 | } 59 | 60 | # vim: ft=perl6 61 | -------------------------------------------------------------------------------- /t/05-unreasonable-requirements.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use Test; 3 | use JSON::Fast; 4 | 5 | plan 7; 6 | 7 | is to-json(Inf), "null", "json standard dictates Inf turns into null"; 8 | is to-json(-Inf), "null", "json standard dictates -Inf turns into null"; 9 | is to-json(NaN), "null", "json standard dictates NaN turns into null"; 10 | 11 | { 12 | my $*JSON_NAN_INF_SUPPORT = 1; 13 | 14 | is to-json(Inf), "Inf", '$*JSON_NAN_INF_SUPPORT allows for Inf'; 15 | is to-json(-Inf), "-Inf", '$*JSON_NAN_INF_SUPPORT allows for -Inf'; 16 | is to-json(NaN), "NaN", '$*JSON_NAN_INF_SUPPORT allows for NaN'; 17 | } 18 | 19 | is from-json(Q["\/\/"]), "//", "backslashed forward slashes get unescaped to forward slashes"; 20 | -------------------------------------------------------------------------------- /t/06-control-characters.t: -------------------------------------------------------------------------------- 1 | use Test; 2 | use JSON::Fast; 3 | 4 | plan 0x21 * 2 + 2; 5 | 6 | my @tests = 7 | "\x[0]" => '"\\u0000"', 8 | "\x[1]" => '"\\u0001"', 9 | "\x[2]" => '"\\u0002"', 10 | "\x[3]" => '"\\u0003"', 11 | "\x[4]" => '"\\u0004"', 12 | "\x[5]" => '"\\u0005"', 13 | "\x[6]" => '"\\u0006"', 14 | "\x[7]" => '"\\u0007"', 15 | "\x[8]" => '"\\u0008"', 16 | "\x[9]" => '"\\t"', 17 | "\x[a]" => '"\\n"', 18 | "\x[b]" => '"\\u000b"', 19 | "\x[c]" => '"\\u000c"', 20 | "\x[d]" => '"\\r"', 21 | "\x[e]" => '"\\u000e"', 22 | "\x[f]" => '"\\u000f"', 23 | "\x[10]" => '"\\u0010"', 24 | "\x[11]" => '"\\u0011"', 25 | "\x[12]" => '"\\u0012"', 26 | "\x[13]" => '"\\u0013"', 27 | "\x[14]" => '"\\u0014"', 28 | "\x[15]" => '"\\u0015"', 29 | "\x[16]" => '"\\u0016"', 30 | "\x[17]" => '"\\u0017"', 31 | "\x[18]" => '"\\u0018"', 32 | "\x[19]" => '"\\u0019"', 33 | "\x[1a]" => '"\\u001a"', 34 | "\x[1b]" => '"\\u001b"', 35 | "\x[1c]" => '"\\u001c"', 36 | "\x[1d]" => '"\\u001d"', 37 | "\x[1e]" => '"\\u001e"', 38 | "\x[1f]" => '"\\u001f"', 39 | "\r\n" => '"\\r\\n"'; 40 | 41 | for @tests { 42 | is (my $result = to-json($_.key)), $_.value, "control character $_.key.ord() => $_.value()"; 43 | is from-json($result), $_.key, "control character goes backwards, too"; 44 | } 45 | 46 | is from-json('"\u1234\r"'), "\x[1234]\r", "simple control character escape plus a unicode sequence"; 47 | is from-json('"\r\u1234"'), "\r\x[1234]", "simple control character escape plus a unicode sequence"; 48 | -------------------------------------------------------------------------------- /t/07-datetime.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use v6; 3 | use lib 'lib'; 4 | use JSON::Fast; 5 | use Test; 6 | 7 | plan 1; 8 | 9 | use MONKEY-TYPING; 10 | augment class DateTime { multi method new(Any:U){ $?CLASS } } 11 | augment class Date { multi method new(Any:U){ $?CLASS } } 12 | 13 | multi sub infix:<=~=>(DateTime:D \l, DateTime:D \r){ l.posix == r.posix } 14 | multi sub infix:<=~=>(DateTime:U \l, DateTime:U \r){ True } 15 | multi sub infix:<=~=>(Date:D \l, Date:D \r){ l.day == r.day && l.month == r.month && l.year == r.year } 16 | multi sub infix:<=~=>(Date:U \l, Date:U \r){ True } 17 | multi sub infix:<=~=>(Date:D \l, DateTime:D \r){ l.day == r.day && l.month == r.month && l.year == r.year } 18 | multi sub infix:<=~=>(Instant:D\l, Instant:D\r){ l.to-posix == r.to-posix } 19 | multi sub infix:<=~=>(Instant:U\l, Instant:U\r){ True } 20 | 21 | 22 | my @data = now.DateTime, DateTime, now, Date.today; 23 | my $json = to-json @data; 24 | 25 | my @data-round-trip := from-json $json; 26 | 27 | my @tripped; 28 | with @data-round-trip { 29 | @tripped.push: DateTime.new(.[0]); 30 | @tripped.push: DateTime.new(.[1]); 31 | @tripped.push: DateTime.new(.[2]).Instant; 32 | @tripped.push: Date.new(.[3]); 33 | } 34 | 35 | ok all(@tripped »=~=« @data), ‚Roundtrip for DateTime instant, DateTime, Date and Instant instant works‘; 36 | 37 | -------------------------------------------------------------------------------- /t/08-sorted-keys.t: -------------------------------------------------------------------------------- 1 | use Test; 2 | use JSON::Fast; 3 | 4 | plan 5; 5 | 6 | sub assert-sorted($obj, @keys = $obj.keys, :$message) { 7 | my $result = to-json($obj, :sorted-keys); 8 | is $_, .sort.List, $message given $result.comb(/@keys/).List; 9 | } 10 | 11 | sub assert-sorted-custom($obj, @keys = $obj.keys, Mu :$sort-option, :$message) { 12 | my $result = to-json($obj, :sorted-keys($sort-option)); 13 | is $_, .sort($sort-option).List, $message given $result.comb(/@keys/).List; 14 | } 15 | 16 | assert-sorted 17 | { foo => 1, 18 | bar => 2, 19 | quux => 3, 20 | aeiou => 4 }; 21 | 22 | assert-sorted 23 | [{ foo => 1, 24 | bar => 2, 25 | quux => 3, 26 | aeiou => 4 },], 27 | , 28 | message => "sorted keys even inside other constructs"; 29 | 30 | assert-sorted 31 | { 32 | "aaaa" => { 33 | "aaac" => 1, 34 | "aaab" => 2, 35 | "aaax" => 3, 36 | "aaaf" => 4 37 | }, 38 | "bbbb" => { 39 | "ccca" => 1, 40 | "cccz" => 2, 41 | "cccf" => 3, 42 | "cccy" => 4 43 | } 44 | }, 45 | , 46 | message => "sorted outer dictionary with inner sorted dictionaries"; 47 | 48 | sub numberword-to-number($_) { 49 | .first(.words.tail, :k) 50 | } 51 | 52 | assert-sorted-custom 53 | [{ foo-one => 1, 54 | foo-three => 3, 55 | foo-four => 4, 56 | foo-two => 2, 57 | foo-nine => 9, 58 | foo-eight => 8, 59 | foo-five => 5, 60 | }], 61 | , 62 | sort-option => &numberword-to-number, 63 | message => "sorted with custom transformation function (1 argument)"; 64 | 65 | assert-sorted-custom 66 | [{ foo-one => 1, 67 | foo-three => 3, 68 | foo-four => 4, 69 | foo-two => 2, 70 | foo-nine => 9, 71 | foo-eight => 8, 72 | foo-five => 5, 73 | }], 74 | , 75 | sort-option => { numberword-to-number($^a) cmp numberword-to-number($^b) }, 76 | message => "sorted with custom transformation function (2 arguments)"; 77 | -------------------------------------------------------------------------------- /t/09-race.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | use v6; 3 | use lib 'lib'; 4 | use JSON::Fast; 5 | use Test; 6 | 7 | plan 1; 8 | 9 | my @out = ( '{ "a" : "1" }' xx 10_000 ) 10 | .race(:degree(8),:batch(100)) 11 | .map: { to-json( from-json($_) ) }; 12 | 13 | is @out.elems, 10_000, 'right number of items'; 14 | 15 | # vim: ft=perl6 16 | -------------------------------------------------------------------------------- /t/10-multidocument.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use JSON::Fast; 4 | use Test; 5 | 6 | my $input = q«[1, 2, 3]{"a": 99, "b": 123} "foo"»; 7 | my @results; 8 | 9 | my $rounds = 0; 10 | 11 | loop { 12 | $rounds++; 13 | last if $rounds > 100; 14 | 15 | @results.push: from-json($input); 16 | 17 | CATCH { 18 | when X::JSON::AdditionalContent { 19 | @results.push: .parsed; 20 | $input = $input.substr(.rest-position) 21 | } 22 | } 23 | last 24 | }; 25 | 26 | is $rounds, 3, "right number of parses"; 27 | is-deeply @results[0], $[1, 2, 3], "first result"; 28 | is-deeply @results[1], ${"a" => 99, "b" => 123}, "second result"; 29 | is-deeply @results[2], "foo", "third result"; 30 | 31 | done-testing; 32 | -------------------------------------------------------------------------------- /t/11-enum.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use JSON::Fast; 4 | use Test; 5 | 6 | enum Bloop ; 7 | 8 | is to-json(Bloop), "null", "enum type gives 'null'"; 9 | is to-json(Squee), '"Squee"', "enum value stringifies to its short name"; 10 | is to-json(Moo), '"Moo"', "enum value stringifies to its short name"; 11 | is to-json(Meep), '"Meep"', "enum value stringifies to its short name"; 12 | 13 | is to-json(Bloop, :enums-as-value), "null", "with enums-as-value: enum type gives 'null'"; 14 | is to-json(Squee, :enums-as-value), '0', "with enums-as-value: enum value stringifies to its integer value"; 15 | is to-json(Moo, :enums-as-value), '1', "with enums-as-value: enum value stringifies to its integer value"; 16 | is to-json(Meep, :enums-as-value), '2', "with enums-as-value: enum value jsonifies to its integer value"; 17 | 18 | enum Blerp (One => "Eins", Two => "Zwei", Three => "Drei"); 19 | 20 | is to-json(Blerp), "null", "enum type gives 'null'"; 21 | is to-json(One), '"One"', "enum value stringifies to its short name"; 22 | is to-json(Two), '"Two"', "enum value stringifies to its short name"; 23 | is to-json(Three), '"Three"', "enum value stringifies to its short name"; 24 | 25 | is to-json(Blerp, :enums-as-value), "null", "with enums-as-value: enum type gives 'null'"; 26 | is to-json(One, :enums-as-value), '"Eins"', "with enums-as-value: enum value stringifies to its integer value"; 27 | is to-json(Two, :enums-as-value), '"Zwei"', "with enums-as-value: enum value stringifies to its integer value"; 28 | is to-json(Three, :enums-as-value), '"Drei"', "with enums-as-value: enum value jsonifies to its integer value"; 29 | 30 | 31 | done-testing; 32 | -------------------------------------------------------------------------------- /t/12-assocpositional.t: -------------------------------------------------------------------------------- 1 | use Test; 2 | use JSON::Fast; 3 | 4 | plan 4; 5 | 6 | class TestClass does Positional does Associative { 7 | method list { 8 | List.new(|do Pair.new($_.Str, $_) for 10 ... 1); 9 | } 10 | 11 | method sort(|c) { 12 | self.list.sort(|c) 13 | } 14 | 15 | method of { 16 | self.Positional::of(); 17 | } 18 | } 19 | 20 | my $expected = %( do $_.Str => $_ for 10 ... 1 ); 21 | 22 | for Bool::.values X Bool::.values -> ($pretty, $sorted-keys) { 23 | my $jsonified = to-json TestClass.new, :$pretty, :$sorted-keys; 24 | my $back = from-json $jsonified; 25 | is-deeply $back, $expected; 26 | } 27 | -------------------------------------------------------------------------------- /t/13-scopes.t: -------------------------------------------------------------------------------- 1 | use Test; 2 | 3 | plan 8; 4 | 5 | my @array = 1,2,3; 6 | my $string := @array.raku.subst(" ", "", :global); 7 | my $list := @array.List; 8 | 9 | { 10 | use JSON::Fast ; 11 | is to-json($list), 12 | $string, 13 | "to-json is not pretty"; 14 | is to-json($list, :pretty), 15 | "[\n 1,\n 2,\n 3\n]", 16 | "to-json override to pretty works"; 17 | 18 | is-deeply from-json($string), 19 | $list, 20 | "from-json is immutable"; 21 | is-deeply from-json($string, :!immutable), 22 | @array, 23 | "from-json override to immutable works"; 24 | } 25 | 26 | { 27 | use JSON::Fast; 28 | is to-json($list), 29 | "[\n 1,\n 2,\n 3\n]", 30 | "to-json is not pretty"; 31 | is to-json($list, :!pretty), 32 | $string, 33 | "to-json override to pretty works"; 34 | 35 | is-deeply from-json($string), 36 | @array, 37 | "from-json is immutable"; 38 | is-deeply from-json($string, :immutable), 39 | $list, 40 | "from-json override to immutable works"; 41 | } 42 | -------------------------------------------------------------------------------- /t/14-comments.t: -------------------------------------------------------------------------------- 1 | use JSON::Fast; 2 | use Test; 3 | 4 | plan 2; 5 | 6 | my $json := Q:to/JSON/; 7 | { 8 | /* This is an example 9 | for block comment */ 10 | "foo": "bar foo", // Comments can 11 | "true": false, // Improve readbility 12 | "number": 42, // Number will always be 42 13 | /* Comments ignored while 14 | generating JSON from JSONC: */ 15 | // "object": { 16 | // "test": "done" 17 | // }, 18 | "array": [1, 2, /* 4, */ 3] 19 | } 20 | JSON 21 | 22 | is-deeply from-json($json, :allow-jsonc), 23 | {:array($[1, 2, 3]), :foo("bar foo"), :number(42), :true(Bool::False)}, 24 | 'did it parse ok, despite comments'; 25 | 26 | dies-ok {from-json($json)}, "comments fail to parse in normal path";; 27 | -------------------------------------------------------------------------------- /xt/meta.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib 'lib'; 4 | use Test; 5 | use Test::META; 6 | 7 | meta-ok; 8 | 9 | done-testing; 10 | --------------------------------------------------------------------------------