Commit: 376428dbc496a40f77de92078a24ef954d49832f - Text-Hjson-perl (git)

Commit MetaInfo

• Revision: 376428dbc496a40f77de92078a24ef954d49832f (tree)
• Time: 2023-04-03 02:42:49
• Author: dyknon <dyknon@user...>
• Commiter: dyknon

Log Message

Optimized

Change Summary

• add: Makefile
• modified: lib/Text/Hjson.pm
• add: lib/Text/Hjson/Grammar.pm
• add: t/additional_string.t
• add: t/empty_root_object.t

Incremental Difference

--- /dev/null
+++ b/Makefile
@@ -0,0 +1,4 @@
+test:
+	perl -mlib=lib t/empty_root_object.t
+	perl -mlib=lib t/additional_string.t
+	perl -mlib=lib t/hjson_official.t

--- a/lib/Text/Hjson.pm
+++ b/lib/Text/Hjson.pm
@@ -4,6 +4,9 @@ use warnings;
 use strict;
 use feature qw(postderef);
 use Carp;
+use Text::Hjson::Grammar;
+
+our $grammar = "Text::Hjson::Grammar";
 
 our $ws = qr/[\t\r\n ]/;
 our $inline_ws = qr/[\t\r ]/;
@@ -29,11 +32,11 @@ sub null($){
     my ($self) = @_;
     undef
 }
-sub array(@){
+sub array($@){
     my ($self, @inner) = @_;
     \@inner
 }
-sub object(@){
+sub object($@){
     my ($self, @inner) = @_;
     my %ret;
     for(@inner){
@@ -41,176 +44,72 @@ sub object(@){
     }
     \%ret
 }
+sub string($$){
+    my ($self, $str) = @_;
+    $str
+}
+sub number($$){
+    my ($self, $num) = @_;
+    $num
+}
+sub decode_quoted_string($$){
+    my ($self, $str) = @_;
 
-our %element = (
-    literal => {
-        re => qr/$wsc(true|false|null)$litend/,
-        act => sub{
-            my ($self, $match) = @_;
-            {
-                true => $self->true,
-                false => $self->false,
-                null => $self->null,
-            }->{$match->[0]}
-        }
-    },
-    separator => {re => qr/$separator/},
-    optional_sep => {re => qr/$separator?/},
-    # XXX: not docuemnted, but tests say quoteless string
-    #      starting with quote is not allowed.
-    quoteless_guard => {re => qr/$wsc(?!["'])/},
-    value => {
-        any => [qw(literal object array number string)],
-        act => sub{$_[2]}
-    },
-    root => {
-        any => [qw(object_member_arr value)],
-        act => sub{$_[2]}
-    },
-    object => {
-        seq => [qw(begin_object object_inner end_object)],
-        act => sub{$_[2]}
-    },
-    begin_object => {re => qr/$wsc\{/},
-    end_object => {re => qr/$wsc\}/},
-    object_inner => {
-        opt => "object_member_arr",
-        act => sub{
-            my ($self, $match) = @_;
-            $match // $self->object;
-        }
-    },
-    object_member_arr => {
-        seq => [qw(object_member object_members optional_sep)],
-        act => sub{
-            my ($self, $first, $left) = @_;
-            $self->object($first, @$left)
-        }
-    },
-    object_member => {
-        seq => [qw(object_key object_key_sep value)],
-        act => sub{
-            my ($self, $key, $sep, $val) = @_;
-            [$key, $val]
-        }
-    },
-    object_members => {
-        many => "separated_object_member",
-        act => sub{shift; [@_]}
-    },
-    separated_object_member => {
-        seq => [qw(separator object_member)],
-        act => sub{$_[2]}
-    },
-    object_key => {
-        any => [qw(string_quoted object_key_noquote)],
-        act => sub{$_[2]}
-    },
-    object_key_noquote => {
-        seq => [qw(quoteless_guard object_key_noquote_body)],
-        act => sub{$_[2]}
-    },
-    object_key_noquote_body => {
-        re => qr/($nonpunct+)/,
-        act => sub{$_[1][0]}
-    },
-    object_key_sep => {re => qr/$wsc:/},
-    array => {
-        seq => [qw(begin_array array_inner end_array)],
-        act => sub{$_[2]}
-    },
-    begin_array => {re => qr/$wsc\[/},
-    end_array => {re => qr/$wsc\]/},
-    array_inner => {
-        opt => "array_member_arr",
-        act => sub{
-            my ($self, $match) = @_;
-            $match // $self->array;
-        }
-    },
-    array_member_arr => {
-        seq => [qw(value array_members optional_sep)],
-        act => sub{
-            my ($self, $first, $left) = @_;
-            $self->array($first, @$left)
-        }
-    },
-    array_members => {
-        many => "separated_array_member",
-        act => sub{shift; [@_]}
-    },
-    separated_array_member => {
-        seq => [qw(separator value)],
-        act => sub{$_[2]}
-    },
-    number => {
-        re => qr/$wsc(-)?+((?:0|[1-9][0-9]*+)(?:\.[0-9]++)?+)(?:[eE]([-+]?+[0-9]++))?+$litend/,
-        act => sub{
-            my ($self, $match) = @_;
-            my $v = $match->[1] * 10**($match->[2] // 0);
-            $match->[0] ? -$v : $v
-        }
-    },
-    string => {
-        any => [qw(string_multiline string_quoted string_noquote)],
-        act => sub{$_[2]}
-    },
-    # XXX: not in RFC but quote by ' is allowed.
-    string_quoted => {
-        re => qr/$wsc(["'])((?:(?!\g{1})[^\0-\x1f\\]|\\["'\\\/bfnrt]|\\u[0-9A-Fa-f]{4})*+)\g{1}/,
-        act => sub{
-            my ($self, $match) = @_;
-            $match->[1] =~ s{\\(u(.{4})|.)}{
-                {
-                    '"' => '"',
-                    "'" => "'",
-                    "\\" => "\\",
-                    "/" => "/",
-                    "b" => "\b",
-                    "f" => "\f",
-                    "n" => "\n",
-                    "r" => "\r",
-                    "t" => "\t",
-                }->{$1} // chr(hex($2))
-            }ger;
-        }
-    },
-    string_noquote => {
-        seq => [qw(quoteless_guard string_noquote_body)],
-        act => sub{$_[2]}
-    },
-    string_noquote_body => {
-        re => qr/(${nonpunct}(?:\t|[^\0-\x1f])*)/,
-        act => sub{
-            my ($self, $match) = @_;
-            $match->[0] =~ s/$inline_ws*+\z//r;
+    # process \uxxxx sequences
+    my $newstr = "";
+    my $pos = 0;
+    while($str =~ /\\u/g){
+        $newstr .= substr($str, $pos, $-[0] - $pos);
+        my $start_hex = $+[0];
+        my $hex = substr($str, $start_hex, 4);
+        die "imcomplete \\u sequence" if(4 != length $hex);
+        die "non-hex char in \\u sequence" if($hex =~ /[^0-9A-Fa-f]/);
+        my $code = hex($hex);
+        die "low surrogate prefixed by no high surrogate in \\u sequence"
+            if(0xdc00 <= $code < 0xe000);
+        if(0xd800 <= $code < 0xdc00){
+            die "high surrogate suffixed by no \\u in \\u sequence"
+                if(substr($str, $start_hex + 4, 2) ne "\\u");
+            my $hex = substr($str, $start_hex + 6, 4);
+            die "imcomplete \\u sequence" if(4 != length $hex);
+            die "non-hex char in \\u sequence" if($hex =~ /[^0-9A-Fa-f]/);
+            my $lowcode = hex($hex);
+            die "high surrogate suffixed by no low surrogate in \\u sequence"
+                unless(0xdc00 <= $lowcode < 0xe000);
+            $newstr .= chr((($code & 0x3ff) + 0x40) << 10 | $lowcode & 0x3ff);
+            pos($str) = $pos = $start_hex + 10;
+        }else{
+            $newstr .= chr($code);
+            pos($str) = $pos = $start_hex + 4;
         }
-    },
-    string_multiline => {
-        re => qr/($wsc)'''((?:(?!''')$any)*+)'''/,
-        act => sub{
-            my ($self, $match) = @_;
-            my $indent = length($match->[0] =~ s/.*\n//r);
-            my $s = $match->[1] =~ s/\r//r;
+    }
+    $str = $newstr . substr($str, $pos) if(length $newstr);
 
-            # XXX: What is "column"
-            $s =~ s/(?<=\n)${inline_ws}{0,$indent}//g;
-            # XXX: RFC says: Whitespace on the first line is ignored.
-            #      my understanding: first line is ignored if it contains only ws.
-            $s =~ s/^$inline_ws*\n//;
+    # process other escape sequences
+    my %escape = (
+        '"' => '"',
+        "'" => "'",
+        "\\" => "\\",
+        "/" => "/",
+        "b" => "\b",
+        "f" => "\f",
+        "n" => "\n",
+        "r" => "\r",
+        "t" => "\t",
+    );
+    $str =~ s{\\(.)}{$escape{$1} // die "invalid escape sequence \\$1";}eg;
 
-            $s =~ s/\n\z//r
-        }
-    },
-);
+    $str
+}
 
 sub consume($$$$){
     my ($self, $what, $in, $at) = @_;
-    my $act = sub{scalar ($element{$what}{act} // sub{})->($self, @_)};
-    croak "unknown consume type: $what" if(!$element{$what});
-    if($element{$what}{re}){
+    croak "unknown grammar: $what" if(!$grammar->can($what));
+    my %g = $grammar->$what();
+    my $act = sub{scalar ($g{act} // sub{})->($self, @_)};
+    if($g{re}){
         pos($in) = $at;
-        if($in =~ /\G$element{$what}{re}/g){
+        if($in =~ /\G$g{re}/g){
             (
                 pos($in),
                 $act->([@{^CAPTURE}])
@@ -218,47 +117,266 @@ sub consume($$$$){
         }else{
             ()
         }
-    }elsif($element{$what}{seq}){
+    }elsif($g{seq}){
         my @got;
-        for($element{$what}{seq}->@*){
+        for($g{seq}->@*){
             ($at, my $read) = $self->consume($_, $in, $at);
             return () if(!defined $at);
             push @got, $read;
         }
         ($at, $act->(@got))
-    }elsif($element{$what}{any}){
+    }elsif($g{any}){
         my ($i, $bt, $read);
-        for $i(0 .. $element{$what}{any}->$#*){
-            ($bt, $read) = $self->consume($element{$what}{any}[$i], $in, $at);
+        for $i(0 .. $g{any}->$#*){
+            ($bt, $read) = $self->consume($g{any}[$i], $in, $at);
             if(defined $bt){
                 return ($bt, $act->($i, $read));
             }
         }
         ()
-    }elsif($element{$what}{many}){
+    }elsif($g{many}){
         my $bt;
         my @got;
         while(1){
-            ($bt, my $read) = $self->consume($element{$what}{many}, $in, $at);
+            ($bt, my $read) = $self->consume($g{many}, $in, $at);
             last if(!defined $bt);
             die "infinite loop detected in $what" if($at == $bt);
             $at = $bt;
             push @got, $read;
         }
         ($at, $act->(@got))
-    }elsif($element{$what}{opt}){
-        my ($bt, $read) = $self->consume($element{$what}{opt}, $in, $at);
+    }elsif($g{opt}){
+        my ($bt, $read) = $self->consume($g{opt}, $in, $at);
         ($bt//$at, $act->($read))
     }else{
-        die "what is $what";
+        die "broken grammar";
+    }
+}
+
+sub consume_value($$$){
+    my ($self, $in, $at) = @_;
+    my $s = substr($in, $at, 1);
+    my @try;
+    if($s eq "{"){
+        @try = qw(consume_object);
+    }elsif($s eq "["){
+        @try = qw(consume_array);
+    }elsif(ord(0) <= ord($s) <= ord(9) || $s eq "-"){
+        @try = qw(consume_number consume_string);
+    }elsif($s eq "t" || $s eq "f" || $s eq "n"){
+        @try = qw(consume_literal consume_string);
+    }else{
+        @try = qw(consume_string);
+    }
+    for(@try){
+        my ($bt, $value) = $self->$_($in, $at);
+        return ($bt, $value) if(defined $bt);
+    }
+    ()
+}
+
+sub consume_root($$$){
+    my ($self, $in, $at) = @_;
+    my $s = substr($in, $at, 1);
+    my @try;
+    if($s eq "{"){
+        @try = qw(consume_object);
+    }elsif($s eq "["){
+        @try = qw(consume_array);
+    }elsif(ord(0) <= ord($s) <= ord(1) || $s eq "-"){
+        @try = qw(consume_root_object consume_number consume_string);
+    }elsif($s eq "t" || $s eq "f" || $s eq "n"){
+        @try = qw(consume_root_object consume_literal consume_string);
+    }else{
+        @try = qw(consume_root_object consume_string);
+    }
+    for(@try){
+        my ($bt, $value) = $self->$_($in, $at);
+        return ($bt, $value) if(defined $bt);
+    }
+    ()
+}
+
+sub consume_literal($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_literal} //= qr/\G(true|false|null)$litend/;
+    pos($in) = $at;
+    if($in =~ /$self->{cre_literal}/g){
+        (pos($in), {
+            true => $self->true,
+            false => $self->false,
+            null => $self->null,
+        }->{$1})
+    }else{()}
+}
+
+sub consume_number($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_number} //= qr/\G(-)?+((?:0|[1-9][0-9]*+)(?:\.[0-9]++)?+)(?:[eE]([-+]?+[0-9]++))?+$litend/;
+
+    pos($in) = $at;
+    if($in =~ /$self->{cre_number}/g){
+        my $v = $2 * 10**($3 // 0);
+        (pos($in), $self->number($1 ? -$v : $v))
+    }else{()}
+}
+
+sub consume_string($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_dquoted_string} //= qr/\G"((?:[^\0-\x1f\\"]|\\.)*+)"/;
+    $self->{cre_squoted_string} //= qr/\G'((?:[^\0-\x1f\\']|\\.)*+)'/;
+    $self->{cre_quoteless_string} //= qr/\G([^'"\0-\x20,:\[\]{}](?:\t|[^\0-\x1f])*)/;
+    my $start1 = substr($in, $at, 1);
+    if($start1 eq "'"){
+        my $start3 = substr($in, $at, 3);
+        if($start3 eq "'''"){
+            pos($in) = $at;
+            die if($in !~ /($inline*)\G/);
+            my $column = length($1);
+            pos($in) = $at + 3;
+            return if($in !~ /\G($any*?)'''/g);
+            my $str = $1;
+            $str =~ s/\r//g;
+            # XXX: it may not compatible with js-Hjson.
+            # but I don't understand 'column' well.
+            $str =~ s/(?<=\n)${inline_ws}{0,$column}//g;
+            # XXX: it is not compatible with js-Hjson. but I think its better.
+            $str =~ s/^$inline_ws*\n//;
+            $str =~ s/\n\z//;
+            (pos($in), $str)
+        }else{
+            pos($in) = $at;
+            return if($in !~ /$self->{cre_squoted_string}/g);
+            (pos($in), $self->decode_quoted_string($1))
+        }
+    }elsif($start1 eq '"'){
+        pos($in) = $at;
+        return if($in !~ /$self->{cre_dquoted_string}/g);
+        (pos($in), $self->decode_quoted_string($1))
+    }else{
+        pos($in) = $at;
+        return if($in !~ /$self->{cre_quoteless_string}/g);
+        (pos($in), $1 =~ s/$inline_ws*+\z//r)
+    }
+}
+
+sub consume_object($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_wsc} //= qr/\G$wsc/;
+
+    return if(substr($in, $at++, 1) ne "{");
+    pos($in) = $at;
+    die if($in !~ /$self->{cre_wsc}/g);
+    ($at, my @content) = $self->consume_object_inner($in, pos($in));
+    return if(!defined $at);
+    pos($in) = $at;
+    die if($in !~ /$self->{cre_wsc}/g);
+    return if(substr($in, pos($in), 1) ne "}");
+    (pos($in)+1, $self->object(@content))
+}
+
+sub consume_root_object($$$){
+    my ($self, $in, $at) = @_;
+    ($at, my @content) = $self->consume_object_inner($in, $at);
+    return if(!defined $at || !@content);
+    ($at, $self->object(@content))
+}
+
+sub consume_object_inner($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_wsc} //= qr/\G$wsc/;
+    $self->{cre_quoteless_key} //= qr/\G([^'"\0-\x20,:\[\]{}][^\0-\x20,:\[\]{}]*)/;
+    $self->{cre_dquoted_string} //= qr/\G"((?:[^\0-\x1f\\"]|\\.)*+)"/;
+    $self->{cre_squoted_string} //= qr/\G'((?:[^\0-\x1f\\']|\\.)*+)'/;
+    $self->{cre_value_separator} //= qr/\G$separator/;
+
+    my @ret;
+    pos($in) = $at;
+    while(1){
+        my $keystart = substr($in, pos($in), 1);
+        return ($at, @ret) if($keystart eq "}" || $keystart eq "");
+        $at = pos($in);
+        my $key;
+        if($keystart eq '"'){
+            return if($in !~ /$self->{cre_dquoted_string}/g); $at = pos($in);
+            $key = $self->decode_quoted_string($1);
+        }elsif($keystart eq "'"){
+            return if($in !~ /$self->{cre_squoted_string}/g); $at = pos($in);
+            $key = $self->decode_quoted_string($1);
+        }else{
+            return if($in !~ /$self->{cre_quoteless_key}/g); $at = pos($in);
+            $key = $1;
+        }
+
+        pos($in) = $at; die if($in !~ /$self->{cre_wsc}/g); $at = pos($in);
+        return if(substr($in, $at++, 1) ne ":");
+        pos($in) = $at; die if($in !~ /$self->{cre_wsc}/g); $at = pos($in);
+
+        ($at, my $value) = $self->consume_value($in, $at); pos($in) = $at;
+        return if(!defined $at);
+
+        push(@ret, [$key, $value]);
+        last if($in !~ /$self->{cre_value_separator}/g); $at = pos($in);
+        die if($in !~ /$self->{cre_wsc}/g);
+    }
+    ($at, @ret)
+}
+
+sub consume_array($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_wsc} //= qr/\G$wsc/;
+    $self->{cre_value_separator} //= qr/\G$separator/;
+
+    return if(substr($in, $at++, 1) ne "[");
+    pos($in) = $at;
+    die if($in !~ /$self->{cre_wsc}/g); $at = pos($in);
+
+    my @content;
+    while(1){
+        my $nextstart = substr($in, pos($in), 1);
+        if($nextstart eq "]"){
+            return (pos($in)+1, $self->array(@content));
+        }
+        return if($nextstart eq "");
+        $at = pos($in);
+
+        ($at, my $value) = $self->consume_value($in, $at); pos($in) = $at;
+        return if(!defined $at);
+
+        push(@content, $value);
+        if($in !~ /$self->{cre_value_separator}/g){
+            pos($in) = $at;
+            die if($in !~ /$self->{cre_wsc}/g);
+            return if(substr($in, pos($in), 1) ne "]");
+            return (pos($in)+1, $self->array(@content));
+        }
+        $at = pos($in);
+        die if($in !~ /$self->{cre_wsc}/g);
+    }
+}
+
+sub consume_wsc($$$){
+    my ($self, $in, $at) = @_;
+    $self->{cre_wsc} //= qr/\G$wsc/;
+    pos($in) = $at;
+    if($in =~ /$self->{cre_wsc}/g){
+        (pos($in), undef)
+    }else{
+        die "bug";
     }
 }
 
 sub decode($$){
     my ($self, $in) = @_;
-    my ($end, $value) = $self->consume("root", $in, 0);
-    croak "Invalid Hjson string" if(!defined $end);
-    pos($in) = $end;
-    croak "Garbage after Hjson value" if($in !~ /\G$wsc\z/g);
+    $self = bless {}, $self if(!length ref $self);
+    my ($p,) = $self->consume_wsc($in, 0);
+    die if(!defined $p);
+    ($p, my $value) = $self->consume_root($in, $p);
+    croak "Invalid Hjson string" if(!defined $p);
+    ($p,) = $self->consume_wsc($in, $p);
+    die if(!defined $p);
+    croak "Garbage after Hjson value" if($p != length($in));
     $value
 }
+
+1;

--- /dev/null
+++ b/lib/Text/Hjson/Grammar.pm
@@ -0,0 +1,181 @@
+package Text::Hjson::Grammar;
+
+use warnings;
+use strict;
+use feature qw(postderef);
+
+our $ws = qr/[\t\r\n ]/;
+our $inline_ws = qr/[\t\r ]/;
+our $inline = qr/$inline_ws|[^\0-\x20]/;
+our $any = qr/$ws|[^\0-\x20]/;
+our $line_comment = qr/(?:#|\/\/)$inline*+/;
+our $block_comment = qr/\/\*(?:[^*]|\*(?!\/))*+\*\//;
+our $comment = qr/$line_comment|$block_comment/;
+our $wsc = qr/(?:$ws|$comment)*+/;
+our $litend = qr/(?![ \t]*+[^\0-\x20#,\/\[\]{}])/;
+our $separator = qr/$wsc,|(?:$inline_ws|$comment)*+\n/;
+our $nonpunct = qr/[^\0-\x20,:\[\]{}]/;
+
+sub literal{
+    re => qr/$wsc(true|false|null)$litend/,
+    act => sub{
+        my ($self, $match) = @_;
+        {
+            true => $self->true,
+            false => $self->false,
+            null => $self->null,
+        }->{$match->[0]}
+    }
+}
+sub separator{re => qr/$separator/}
+sub optional_sep{re => qr/$separator?/}
+# XXX: not docuemnted, but tests say quoteless string
+#      starting with quote is not allowed.
+sub quoteless_guard{re => qr/$wsc(?!["'])/}
+sub value{
+    any => [qw(literal object array number string)],
+    act => sub{$_[2]}
+}
+sub root{
+    any => [qw(object_member_arr value)],
+    act => sub{$_[2]}
+}
+sub object{
+    seq => [qw(begin_object object_inner end_object)],
+    act => sub{$_[2]}
+}
+sub begin_object{re => qr/$wsc\{/}
+sub end_object{re => qr/$wsc\}/}
+sub object_inner{
+    opt => "object_member_arr",
+    act => sub{
+        my ($self, $match) = @_;
+        $match // $self->object
+    }
+}
+sub object_member_arr{
+    seq => [qw(object_member object_members optional_sep)],
+    act => sub{
+        my ($self, $first, $left) = @_;
+        $self->object($first, @$left)
+    }
+}
+sub object_member{
+    seq => [qw(object_key object_key_sep value)],
+    act => sub{
+        my ($self, $key, $sep, $val) = @_;
+        [$key, $val]
+    }
+}
+sub object_members{
+    many => "separated_object_member",
+    act => sub{shift; [@_]}
+}
+sub separated_object_member{
+    seq => [qw(separator object_member)],
+    act => sub{$_[2]}
+}
+sub object_key{
+    any => [qw(string_quoted object_key_noquote)],
+    act => sub{$_[2]}
+}
+sub object_key_noquote{
+    seq => [qw(quoteless_guard object_key_noquote_body)],
+    act => sub{$_[2]}
+}
+sub object_key_noquote_body{
+    re => qr/($nonpunct+)/,
+    act => sub{$_[1][0]}
+}
+sub wsc{re => qr/$wsc/}
+sub object_key_sep{re => qr/$wsc:/}
+sub array{
+    seq => [qw(begin_array array_inner end_array)],
+    act => sub{$_[2]}
+}
+sub begin_array{re => qr/$wsc\[/}
+sub end_array{re => qr/$wsc\]/}
+sub array_inner{
+    opt => "array_member_arr",
+    act => sub{
+        my ($self, $match) = @_;
+        $match // $self->array;
+    }
+}
+sub array_member_arr{
+    seq => [qw(value array_members optional_sep)],
+    act => sub{
+        my ($self, $first, $left) = @_;
+        $self->array($first, @$left)
+    }
+}
+sub array_members{
+    many => "separated_array_member",
+    act => sub{shift; [@_]}
+}
+sub separated_array_member{
+    seq => [qw(separator value)],
+    act => sub{$_[2]}
+}
+sub number{
+    re => qr/$wsc(-)?+((?:0|[1-9][0-9]*+)(?:\.[0-9]++)?+)(?:[eE]([-+]?+[0-9]++))?+$litend/,
+    act => sub{
+        my ($self, $match) = @_;
+        my $v = $match->[1] * 10**($match->[2] // 0);
+        $match->[0] ? -$v : $v
+    }
+}
+sub string{
+    any => [qw(string_multiline string_quoted string_noquote)],
+    act => sub{$_[2]}
+}
+# XXX: not in RFC but quote by ' is allowed.
+sub string_quoted{
+    re => qr/$wsc(["'])((?:(?!\g{1})[^\0-\x1f\\]|\\.)*+)\g{1}/,
+    act => sub{
+        my ($self, $match) = @_;
+        $self->string($self->decode_quoted_string($match->[1]))
+        #$match->[1] =~ s{\\(u(.{4})|.)}{
+        #    {
+        #        '"' => '"',
+        #        "'" => "'",
+        #        "\\" => "\\",
+        #        "/" => "/",
+        #        "b" => "\b",
+        #        "f" => "\f",
+        #        "n" => "\n",
+        #        "r" => "\r",
+        #        "t" => "\t",
+        #    }->{$1} // chr(hex($2))
+        #}ger;
+    }
+}
+sub string_noquote{
+    seq => [qw(quoteless_guard string_noquote_body)],
+    act => sub{$_[2]}
+}
+sub string_noquote_body{
+    re => qr/(${nonpunct}(?:\t|[^\0-\x1f])*)/,
+    act => sub{
+        my ($self, $match) = @_;
+        $match->[0] =~ s/$inline_ws*+\z//r;
+    }
+}
+sub string_multiline{
+    re => qr/($wsc)'''((?:(?!''')$any)*+)'''/,
+    act => sub{
+        my ($self, $match) = @_;
+        my $indent = length($match->[0] =~ s/.*\n//r);
+        my $s = $match->[1] =~ s/\r//r;
+
+        # XXX: What is "column"
+        $s =~ s/(?<=\n)${inline_ws}{0,$indent}//g;
+        # XXX: RFC says: Whitespace on the first line is ignored.
+        #      my understanding: first line is ignored if it contains only ws.
+        $s =~ s/^$inline_ws*\n//;
+
+        $s =~ s/\n\z//r
+    }
+}
+
+1;

--- /dev/null
+++ b/t/additional_string.t
@@ -0,0 +1,61 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use utf8;
+use Test2::V0;
+use Text::Hjson;
+use Data::Dumper;
+
+my $v;
+
+# quoteless strings with quotation marks
+eval{Text::Hjson->decode("{v: 'invalid\n}")};
+ok($@, "quoteless string starting with single quote");
+eval{Text::Hjson->decode("{v: \"invalid\n}")};
+ok($@, "quoteless string starting with double quote");
+$v = eval{Text::Hjson->decode("{v: valid\"\n}")};
+is($v, {v => 'valid"'}, "quoteless string with quote at the end");
+
+# quoteless object keys with quotation marks
+eval{Text::Hjson->decode("{'invalid: v\n}")};
+ok($@, "quoteless object key starting with single quote");
+eval{Text::Hjson->decode("{\"invalid: v\n}")};
+ok($@, "quoteless object key starting with double quote");
+$v = eval{Text::Hjson->decode("{valid\": v\n}")};
+is($v, {'valid"' => "v"}, "quoteless object key with quote at the end");
+
+# invalid escape sequence
+eval{Text::Hjson->decode('"\z"')};
+ok($@, "invalid sequence \\z");
+eval{Text::Hjson->decode('"\!"')};
+ok($@, "invalid sequence \\!");
+
+# surrogates
+eval{Text::Hjson->decode('"\ud835"')};
+ok($@, "only high surrogate");
+eval{Text::Hjson->decode('"\ud835!"')};
+ok($@, "high surrogate before non-surrogate");
+eval{Text::Hjson->decode('"\ud835\u003f"')};
+ok($@, "high surrogate before non-surrogate \\u sequence");
+eval{Text::Hjson->decode('"HH:\ud835\ud835"')};
+ok($@, "repeating high surrogate");
+eval{Text::Hjson->decode('"L:\udc2c"')};
+ok($@, "only low surrogate");
+eval{Text::Hjson->decode('"L:\udc2c\udc2c"')};
+ok($@, "repeating low surrogate");
+eval{Text::Hjson->decode('"L:\udc2c\ud835\udc2c"')};
+ok($@, "low surrogate before high surrogate");
+eval{Text::Hjson->decode("'\\ud835\x{dc2c}'")};
+ok($@, "\\u encode only a half of a surrogate pair");
+$v = eval{Text::Hjson->decode('"pairs: \ud835\udc12\ud835\udc2e\ud835\udc2b\ud835\udc2b\ud835\udc28\ud835\udc20\ud835\udc1a\ud835\udc2d\ud835\udc1e\ud835\udc2c!!"')};
+print($@);
+is($v, "pairs: 𝐒𝐮𝐫𝐫𝐨𝐠𝐚𝐭𝐞𝐬!!", "Correct surrogate pairs");
+
+# CR
+$v = eval{Text::Hjson->decode("      '''abc\r\nde\rf\n\rghi\rjkl\n\n'''")};
+is($v, "abc\ndef\nghijkl\n", "\\r in multiline string");
+$v = eval{Text::Hjson->decode("abc\r\n")};
+is($v, "abc", "\\r at the end of a quoteless string");
+
+done_testing

--- /dev/null
+++ b/t/empty_root_object.t
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use utf8;
+use Test2::V0;
+use Text::Hjson;
+
+eval{Text::Hjson->decode("")};
+ok($@, "empty toplevel object");
+
+eval{Text::Hjson->decode("#test\n")};
+ok($@, "only a comment");
+
+done_testing;