Merge pull request ocaml-community#150 from ocaml-community/mj-out-of…

…-bounds

Fix out-of-bounds error in atdgen parsers

CHANGES.md

@@ -14,6 +14,9 @@
 
 ### Fixed
 
+- Fix out-of-bounds error occurring when parsing object field names
+  with atdgen parsers using `map_ident` or `map_lexeme` (@mjambon, #150)
+
 ## 2.0.1
 
 *2022-06-28*

lib/read.mll

@@ -151,7 +151,7 @@
 
   let map_lexeme f lexbuf =
     let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in
-    f (Bytes.sub_string lexbuf.lex_buffer lexbuf.lex_start_pos len) lexbuf.lex_start_pos len
+    f (Bytes.sub_string lexbuf.lex_buffer lexbuf.lex_start_pos len) 0 len
 
   type variant_kind = [ `Edgy_bracket | `Square_bracket | `Double_quote ]
   type tuple_kind = [ `Parenthesis | `Square_bracket ]

test/fixtures.ml

@@ -20,6 +20,10 @@ let json_string =
   ^ {|"list":[0,1,2]|}
   ^ "}"
 
+let unquoted_json = {|{foo: null}|}
+
+let unquoted_value = `Assoc [("foo", `Null)]
+
 let json_string_newline =
   json_string
   ^ "\n"

test/fixtures.mli

@@ -8,3 +8,6 @@ val json_string : string
 
 (** The same JSON string terminated with a newline *)
 val json_string_newline : string
+
+val unquoted_json : string
+val unquoted_value : Yojson.Safe.t

test/test_read.ml

@@ -12,7 +12,50 @@ let from_file () =
   Alcotest.(check Testable.yojson) __LOC__ Fixtures.json_value (Yojson.Safe.from_file input_file);
   Sys.remove input_file
 
+let unquoted_from_string () =
+  Alcotest.(check Testable.yojson)
+    __LOC__
+    Fixtures.unquoted_value
+    (Yojson.Safe.from_string Fixtures.unquoted_json)
+
+let map_ident_and_string () =
+  let lexbuf = Lexing.from_string {|{foo:"hello"}|} in
+  let lexer_state = Yojson.init_lexer () in
+
+  let ident_expected expectation reference start len =
+    let identifier = String.sub reference start len in
+    Alcotest.(check string)
+      (Format.asprintf "Reference '%s' start %d len %d matches '%s'" reference start len expectation)
+      expectation
+      identifier;
+    ()
+  in
+  let skip_over f =
+    f lexer_state lexbuf
+  in
+  let map_f mapper f =
+    mapper lexer_state f lexbuf
+  in
+  let map_ident = map_f Yojson.Safe.map_ident in
+  let map_string = map_f Yojson.Safe.map_string in
+
+  skip_over Yojson.Safe.read_lcurl;
+  map_ident (ident_expected "foo");
+  skip_over Yojson.Safe.read_colon;
+
+  let variant = skip_over Yojson.Safe.start_any_variant in
+  Alcotest.(check Testable.variant_kind) "String starts with double quote" `Double_quote variant;
+
+  map_string (ident_expected "hello");
+
+  Alcotest.check_raises
+    "Reading } raises End_of_object"
+    Yojson.End_of_object
+    (fun () -> Yojson.Safe.read_object_end lexbuf)
+
 let single_json = [
   "from_string", `Quick, from_string;
   "from_file", `Quick, from_file;
+  "unquoted_from_string", `Quick, unquoted_from_string;
+  "map_ident/map_string", `Quick, map_ident_and_string;
 ]

test/testable.ml

@@ -1 +1,15 @@
 let yojson = Alcotest.testable Yojson.Safe.pp Yojson.Safe.equal
+
+let variant_kind_pp fmt = function
+  | `Edgy_bracket -> Format.fprintf fmt "`Edgy_bracket"
+  | `Square_bracket -> Format.fprintf fmt "`Square_bracket"
+  | `Double_quote -> Format.fprintf fmt "`Double_quote"
+
+let variant_kind_equal a b =
+  match a, b with
+  | `Edgy_bracket, `Edgy_bracket -> true
+  | `Square_bracket, `Square_bracket -> true
+  | `Double_quote, `Double_quote -> true
+  | _ -> false
+
+let variant_kind = Alcotest.testable variant_kind_pp variant_kind_equal

test/testable.mli

@@ -1 +1,2 @@
 val yojson : Yojson.Safe.t Alcotest.testable
+val variant_kind : Yojson.Safe.variant_kind Alcotest.testable