Merge pull request #18 from jonludlam/better-parser

Better parser

_oasis

@@ -10,5 +10,18 @@ BuildTools:  ocamlbuild
 Library "mirage-bootvar"
   Path:              lib/
   Findlibname:       mirage-bootvar
-  BuildDepends:      lwt, mirage-xen, re, re.str
-  Modules:           Bootvar
+  BuildDepends:      lwt, mirage-xen, astring
+  Modules:           Bootvar, Parse_argv
+
+Executable test
+  CompiledObject:     best
+  Path:               lib_test
+  MainIs:             test.ml
+  Custom:             true
+  Install:            false
+  BuildDepends:       mirage-bootvar, oUnit
+
+Test test
+  Command:            ./test.native
+  Run:                true
+

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 133f156ecf1c693a14afb3964cf8ef2b)
+# DO NOT EDIT (digest: 3853225690c42cd559f1aa3b19b38d2f)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -16,9 +16,20 @@ true: annot, bin_annot
 "_darcs": not_hygienic
 # Library mirage-bootvar
 "lib/mirage-bootvar.cmxs": use_mirage-bootvar
+<lib/*.ml{,i,y}>: pkg_astring
 <lib/*.ml{,i,y}>: pkg_lwt
 <lib/*.ml{,i,y}>: pkg_mirage-xen
-<lib/*.ml{,i,y}>: pkg_re
-<lib/*.ml{,i,y}>: pkg_re.str
+# Executable test
+<lib_test/test.{native,byte}>: pkg_astring
+<lib_test/test.{native,byte}>: pkg_lwt
+<lib_test/test.{native,byte}>: pkg_mirage-xen
+<lib_test/test.{native,byte}>: pkg_oUnit
+<lib_test/test.{native,byte}>: use_mirage-bootvar
+<lib_test/*.ml{,i,y}>: pkg_astring
+<lib_test/*.ml{,i,y}>: pkg_lwt
+<lib_test/*.ml{,i,y}>: pkg_mirage-xen
+<lib_test/*.ml{,i,y}>: pkg_oUnit
+<lib_test/*.ml{,i,y}>: use_mirage-bootvar
+<lib_test/test.{native,byte}>: custom
 # OASIS_STOP
 true: warn(A-44), strict_sequence

lib/META

@@ -1,8 +1,8 @@
 # OASIS_START
-# DO NOT EDIT (digest: ff82d10e7a79d087716284ae5afe3e38)
+# DO NOT EDIT (digest: 2ae3a7a5bbf2b02fa0678ceab4f6f9ca)
 version = "0.3.1"
 description = "Library for reading MirageOS unikernel boot parameters in Xen"
-requires = "lwt mirage-xen re re.str"
+requires = "lwt mirage-xen astring"
 archive(byte) = "mirage-bootvar.cma"
 archive(byte, plugin) = "mirage-bootvar.cma"
 archive(native) = "mirage-bootvar.cmxa"

lib/bootvar.ml

@@ -34,22 +34,29 @@ let get_cmd_line () =
        Lwt.return cmdline)
 
 let create () = 
-  get_cmd_line () >>= fun cmd_line ->
-  let entries = Re_str.(split (regexp_string " ") cmd_line) in
-  let parameters =
-    List.map (fun x ->
-        match Re_str.(split (regexp_string "=") x) with 
-        | [a;b] -> (a,b)
-        | _ -> raise (Failure (Printf.sprintf "Malformed boot parameter %S" x))
-      ) entries
+  get_cmd_line () >>= fun cmd_line_raw ->
+  (* Strip leading whitespace *)
+  let entries = Parse_argv.parse cmd_line_raw in
+  let filter_map fn l =
+    List.fold_left (fun acc x ->
+        match fn x with Some y -> y::acc | None -> acc) [] l
   in
-  let t = 
-    try 
-      `Ok { cmd_line; parameters}
-    with 
-      Failure msg -> `Error msg
+  let result =
+    match entries with
+    | `Ok l ->
+      let parameters =
+        filter_map (fun x ->
+            match Astring.String.cut ~sep:"=" x with
+            | Some (a,b) ->
+              Some (a,b)
+            | _ ->
+              Printf.printf "Ignoring malformed parameter: %s\n" x; None
+          ) l
+      in
+      `Ok { cmd_line=cmd_line_raw ; parameters}
+    | `Error _ as e -> e
   in
-  return t
+  return result
 
 let get_exn t parameter = 
   try

lib/mirage-bootvar.mldylib

@@ -1,4 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 64a1fd59a37fc080f5125673cfa49c01)
+# DO NOT EDIT (digest: 621d71e2d7947006d1c33a3bc5856582)
 Bootvar
+Parse_argv
 # OASIS_STOP

lib/mirage-bootvar.mllib

@@ -1,4 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 64a1fd59a37fc080f5125673cfa49c01)
+# DO NOT EDIT (digest: 621d71e2d7947006d1c33a3bc5856582)
 Bootvar
+Parse_argv
 # OASIS_STOP

lib/parse_argv.ml

@@ -0,0 +1,67 @@
+(*
+ * Copyright (c) 2016 Citrix Systems Inc
+ * 
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+open Astring
+
+(* Split string into whitespace-separated substrings,
+   taking into account quoting *)
+
+let parse s =
+  let skip_white s = String.Sub.drop
+      ~max:Sys.max_string_length
+      ~sat:Char.Ascii.is_white s in
+
+  let split s =
+    let rec inner in_quoted s so_far acc =
+      let is_data = function
+        | '\\' -> false
+        | '"' -> false
+        | c when Char.Ascii.is_white c -> in_quoted
+        | _ -> true in
+
+      let data,rem = String.Sub.span
+          ~sat:is_data
+          ~max:Sys.max_string_length s in
+
+      match String.Sub.head rem with
+      | Some c when Char.Ascii.is_white c ->
+        let so_far = List.rev (data :: so_far) in
+        inner in_quoted (skip_white rem) [] ((String.Sub.concat so_far)::acc)
+      | Some '"' ->
+        let so_far = data :: so_far in
+        inner (not in_quoted) (String.Sub.tail rem) so_far acc
+      | Some '\\' ->
+        let rem = String.Sub.tail rem in
+        begin match String.Sub.head rem with
+          | Some c ->
+            let so_far' = String.(sub (of_char c)) :: data :: so_far in
+            inner in_quoted (String.Sub.tail rem) so_far' acc
+          | None ->
+            `Error "Invalid escaping at end of string"
+        end
+      | Some c ->
+        let e = Printf.sprintf "Something went wrong in the argv parser: Matched '%c'" c in
+        `Error e
+      | None ->
+        let so_far = List.rev (data :: so_far) in
+        `Ok (List.map (String.Sub.to_string) (List.rev ((String.Sub.concat so_far) :: acc)))
+    in
+    inner false s [] []
+  in
+  match split (String.sub s |> skip_white) with
+  | `Ok s -> `Ok (List.filter (fun s -> String.length s > 0) s)
+  | `Error _ as e -> e

lib_test/test.ml

@@ -0,0 +1,68 @@
+(*
+ * Copyright (c) 2016 Citrix Systems Inc
+ * 
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+open OUnit
+
+let verbose = ref false
+
+let log = Printf.ksprintf (fun s -> if !verbose then Printf.fprintf stdout "%s\n%!" s)
+
+let tests =
+  [ "foo bar baz", `Ok ["foo"; "bar"; "baz"];
+    "foo \"bar\" baz", `Ok ["foo"; "bar"; "baz"];
+    "f\\\ oo b\\\"r baz", `Ok ["f oo"; "b\"r"; "baz"];
+    "foo bar\"bie\"boo baz", `Ok ["foo"; "barbieboo"; "baz"];
+    "  ", `Ok []
+  ]
+
+let test_parse () =
+  List.iter (fun (input, expected) ->
+      log "checking '%s'" input;
+      let result = Parse_argv.parse input in
+      if result <> expected
+      then begin
+        let tostr l =
+          match l with
+          | `Ok list ->
+            String.concat ","
+              (List.map (fun x -> Printf.sprintf "'%s'" x) list)
+          | `Error e -> Printf.sprintf "Error: %s" e
+        in
+        Printf.fprintf stderr "Error - failed to parse. Got:\n%s\nExpected\n%s\n"
+          (tostr result) (tostr expected)
+      end;
+      assert (result=expected)) tests
+
+let negative_test () =
+  let str = "  \\" in
+  log "Testing parse of %s (should fail)" str;
+  match Parse_argv.parse str with
+  | `Ok x -> assert false
+  | `Error _ -> ()
+
+let _ =
+  Arg.parse [
+    "-verbose", Arg.Unit (fun _ -> verbose := true), "Run in verbose mode";
+  ] (fun x -> Printf.fprintf stderr "Ignoring argument: %s" x)
+  "Test argv parser";
+
+  let suite = "parser" >::: [
+    "test parse" >:: test_parse;
+    "negative test" >:: negative_test;
+  ] in
+  run_test_tt ~verbose:!verbose suite
+

myocamlbuild.ml

@@ -1,5 +1,5 @@
 (* OASIS_START *)
-(* DO NOT EDIT (digest: b47c6818ad0cd3760037edfeaaf18754) *)
+(* DO NOT EDIT (digest: ba79fc10ff4623c02c08e8d286f74241) *)
 module OASISGettext = struct
 (* # 22 "src/oasis/OASISGettext.ml" *)
 
@@ -610,7 +610,7 @@ let package_default =
      MyOCamlbuildBase.lib_ocaml = [("mirage-bootvar", ["lib"], [])];
      lib_c = [];
      flags = [];
-     includes = []
+     includes = [("lib_test", ["lib"])]
   }
   ;;
 

opam

@@ -7,7 +7,13 @@ bug-reports: "https://github.com/mirage/mirage-bootvar-xen/issues/"
 dev-repo: "https://github.com/mirage/mirage-bootvar-xen.git"
 license: "ISC"
 build: [
-  [make]
+  ["ocaml" "setup.ml" "-configure" "--disable-tests"]
+  ["ocaml" "setup.ml" "-build"]
+]
+build-test: [
+  ["ocaml" "setup.ml" "-configure" "--enable-tests"]
+  ["ocaml" "setup.ml" "-build"]
+  ["ocaml" "setup.ml" "-test"]
 ]
 install: [make "install"]
 remove: [
@@ -17,5 +23,5 @@ depends: [
   "mirage-xen" { >= "2.2.0" }
   "mirage-types"
   "ipaddr"
-  "re"
+  "astring"
 ]