Skip to content
Browse files

PR#5212: Fix: ocamlbuild does not warn for bad input

Patch by Ygrek!

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13193 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent f2c4cb5 commit f50520d809b606a07bca5de8c5e95562463bea4b meyer committed Jan 1, 2013
View
1 Changes
@@ -13,6 +13,7 @@ Bug fixes:
- PR#4994: ocaml-mode doesn't work with xemacs21
* PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails,
rather than raising 'Not_found'
+- PR#5212: Improve ocamlbuild error messages of _tags parser
- PR#5327: (Windows) Unix.select blocks if same socket listed in first and
third arguments
- PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound)
View
2 ocamlbuild/command.ml
@@ -101,7 +101,7 @@ let env_path = lazy begin
let paths =
try
parse_path (Lexing.from_string path_var)
- with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg))
+ with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos))
in
let norm_current_dir_name path =
if path = "" then Filename.current_dir_name else path
View
16 ocamlbuild/configuration.ml
@@ -32,17 +32,17 @@ let (configs, add_config) =
configs := config :: !configs;
Hashtbl.clear cache)
-let parse_string s =
- let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in
+let parse_lexbuf ?dir source lexbuf =
+ lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source };
+ let conf = Lexers.conf_lines dir lexbuf in
add_config conf
+let parse_string s = parse_lexbuf (Printf.sprintf "String %S" s) (Lexing.from_string s)
+
let parse_file ?dir file =
- try
- with_input_file file begin fun ic ->
- let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in
- add_config conf
- end
- with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg))
+ with_input_file file begin fun ic ->
+ parse_lexbuf ?dir (Printf.sprintf "File %S" file) (Lexing.from_channel ic)
+ end
let key_match = Glob.eval
View
2 ocamlbuild/findlib.ml
@@ -110,7 +110,7 @@ let rec query name =
(* TODO: Improve to differenciate whether ocamlfind cannot be
run or is not installed *)
error Cannot_run_ocamlfind
- | Lexers.Error s ->
+ | Lexers.Error (s,_) ->
error (Cannot_parse_query (name, s))
let split_nl s =
View
4 ocamlbuild/lexers.mli
@@ -12,7 +12,7 @@
(* Original author: Nicolas Pouillard *)
-exception Error of string
+exception Error of (string * Lexing.position)
type conf_values =
{ plus_tags : string list;
@@ -36,7 +36,7 @@ val parse_environment_path : Lexing.lexbuf -> string list
(* Same one, for Windows (PATH is ;-separated) *)
val parse_environment_path_w : Lexing.lexbuf -> string list
-val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf
+val conf_lines : string option -> Lexing.lexbuf -> conf
val path_scheme : bool -> Lexing.lexbuf ->
[ `Word of string
| `Var of (string * Glob.globber)
View
68 ocamlbuild/lexers.mll
@@ -13,7 +13,10 @@
(* Original author: Nicolas Pouillard *)
{
-exception Error of string
+exception Error of (string * Lexing.position)
+
+let error lexbuf fmt = Printf.ksprintf (fun s -> raise (Error (s,Lexing.lexeme_start_p lexbuf))) fmt
+
open Glob_ast
type conf_values =
@@ -42,45 +45,45 @@ let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])*
rule ocamldep_output = parse
| ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf }
| eof { [] }
- | _ { raise (Error "Expecting colon followed by space-separated module name list") }
+ | _ { error lexbuf "Expecting colon followed by space-separated module name list" }
and space_sep_strings_nl = parse
| space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf }
- | space* newline { [] }
- | _ { raise (Error "Expecting space-separated strings terminated with newline") }
+ | space* newline { Lexing.new_line lexbuf; [] }
+ | _ { error lexbuf "Expecting space-separated strings terminated with newline" }
and space_sep_strings = parse
| space* (not_blank+ as word) { word :: space_sep_strings lexbuf }
| space* newline? eof { [] }
- | _ { raise (Error "Expecting space-separated strings") }
+ | _ { error lexbuf "Expecting space-separated strings" }
and blank_sep_strings = parse
| blank* '#' not_newline* newline { blank_sep_strings lexbuf }
| blank* '#' not_newline* eof { [] }
| blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf }
| blank* eof { [] }
- | _ { raise (Error "Expecting blank-separated strings") }
+ | _ { error lexbuf "Expecting blank-separated strings" }
and comma_sep_strings = parse
| space* (not_space_nor_comma+ as word) space* eof { [word] }
| space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting comma-separated strings (1)") }
+ | _ { error lexbuf "Expecting comma-separated strings (1)" }
and comma_sep_strings_aux = parse
| space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting comma-separated strings (2)") }
+ | _ { error lexbuf "Expecting comma-separated strings (2)" }
and comma_or_blank_sep_strings = parse
| space* (not_space_nor_comma+ as word) space* eof { [word] }
| space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") }
+ | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" }
and comma_or_blank_sep_strings_aux = parse
| space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf }
| space* eof { [] }
- | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") }
+ | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" }
and parse_environment_path_w = parse
| ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
@@ -89,7 +92,7 @@ and parse_environment_path_w = parse
and parse_environment_path_aux_w = parse
| ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
| eof { [] }
- | _ { raise (Error "Impossible: expecting colon-separated strings") }
+ | _ { error lexbuf "Impossible: expecting colon-separated strings" }
and parse_environment_path = parse
| ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
@@ -98,31 +101,35 @@ and parse_environment_path = parse
and parse_environment_path_aux = parse
| ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
| eof { [] }
- | _ { raise (Error "Impossible: expecting colon-separated strings") }
+ | _ { error lexbuf "Impossible: expecting colon-separated strings" }
-and conf_lines dir pos err = parse
- | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf }
+and conf_lines dir = parse
+ | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
| space* '#' not_newline* eof { [] }
- | space* newline { conf_lines dir (pos + 1) err lexbuf }
+ | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf }
| space* eof { [] }
| space* (not_newline_nor_colon+ as k) space* ':' space*
{
- let bexpr = Glob.parse ?dir k in
- let v1 = conf_value pos err empty lexbuf in
- let v2 = conf_values pos err v1 lexbuf in
- let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest
+ let bexpr =
+ try Glob.parse ?dir k
+ with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn)
+ in
+ let v1 = conf_value empty lexbuf in
+ let v2 = conf_values v1 lexbuf in
+ Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *)
+ let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest
}
- | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) }
+ | _ { error lexbuf "Invalid line syntax" }
-and conf_value pos err x = parse
+and conf_value x = parse
| '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } }
| '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } }
- | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) }
+ | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" }
-and conf_values pos err x = parse
- | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf }
+and conf_values x = parse
+ | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf }
| (newline | eof) { x }
- | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) }
+ | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" }
and path_scheme patt_allowed = parse
| ([^ '%' ]+ as prefix)
@@ -133,14 +140,13 @@ and path_scheme patt_allowed = parse
{ if patt_allowed then
let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in
`Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf
- else raise (Error(
- Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)"
- var patt)) }
+ else
+ error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt }
| '%'
{ `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf }
| eof
{ [] }
- | _ { raise (Error("Bad pathanme scheme")) }
+ | _ { error lexbuf "Bad pathanme scheme" }
and unescape = parse
| '\\' (['(' ')'] as c) { c :: unescape lexbuf }
@@ -156,11 +162,11 @@ and ocamlfind_query = parse
"linkopts:" space* (not_newline* as lo) newline+
"location:" space* (not_newline* as l) newline+
{ n, d, v, a, lo, l }
- | _ { raise (Error "Bad ocamlfind query") }
+ | _ { error lexbuf "Bad ocamlfind query" }
and trim_blanks = parse
| blank* (not_blank* as word) blank* { word }
- | _ { raise (Error "Bad input for trim_blanks") }
+ | _ { error lexbuf "Bad input for trim_blanks" }
and tag_gen = parse
| (normal+ as name) ('(' ([^')']* as param) ')')? { name, param }
View
5 ocamlbuild/main.ml
@@ -277,8 +277,9 @@ let main () =
| Ocaml_utils.Ocamldep_error msg ->
Log.eprintf "Ocamldep error: %s" msg;
exit rc_ocamldep_error
- | Lexers.Error msg ->
- Log.eprintf "Lexical analysis error: %s" msg;
+ | Lexers.Error (msg,pos) ->
+ let module L = Lexing in
+ Log.eprintf "%s, line %d, column %d: Lexing error: %s." pos.L.pos_fname pos.L.pos_lnum (pos.L.pos_cnum - pos.L.pos_bol) msg;
exit rc_lexing_error
| Arg.Bad msg ->
Log.eprintf "%s" msg;
View
2 ocamlbuild/ocaml_utils.ml
@@ -145,7 +145,7 @@ let read_path_dependencies =
with_input_file depends begin fun ic ->
let ocamldep_output =
try Lexers.ocamldep_output (Lexing.from_channel ic)
- with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
+ with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in
let deps =
List.fold_right begin fun (path, deps) acc ->
let module_name' = module_name_of_pathname path in
View
16 ocamlbuild/testsuite/level0.ml
@@ -64,10 +64,16 @@ test "camlp4.opt"
~matching:[M.x "dummy.native" ~output:"Hello"]
~targets:("dummy.native",[]) ();;
-test "TagsErrorMessage"
- ~description:"Confirm relevance of an error message due to erronous _tags"
- ~failing_msg:"Failure: lexing: empty token."
- ~tree:[T.f "_tags" ~content:"* : not_hygienic"]
- ~targets:("none.native",[]) ();;
+let tag_pat_msgs =
+ ["*:a", "File \"_tags\", line 1, column 0: Lexing error: Invalid globbing pattern \"*\".";
+ "\n<*{>:a", "File \"_tags\", line 2, column 0: Lexing error: Invalid globbing pattern \"<*{>\".";
+ "<*>: ~@a,# ~a", "File \"_tags\", line 1, column 10: Lexing error: Only ',' separated tags are alllowed."];;
+
+List.iteri (fun i (content,failing_msg) ->
+ test (Printf.sprintf "TagsErrorMessage_%d" (i+1))
+ ~description:"Confirm relevance of an error message due to erronous _tags"
+ ~failing_msg
+ ~tree:[T.f "_tags" ~content; T.f "dummy.ml"]
+ ~targets:("dummy.native",[]) ()) tag_pat_msgs;;
run ~root:"_test";;

0 comments on commit f50520d

Please sign in to comment.
Something went wrong with that request. Please try again.