more error checking for external names, fix #657, #658

Author: Hongbo Zhang

jscomp/syntax/ast_external_attributes.ml

@@ -72,6 +72,51 @@ type ffi =
 
 type prim =  Primitive.description
 
+let valid_js_char =
+  let a = Array.init 256 (fun i ->
+    let c = Char.chr i in
+    (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '$'
+  ) in
+  (fun c -> Array.unsafe_get a (Char.code c))
+
+let valid_first_js_char = 
+  let a = Array.init 256 (fun i ->
+    let c = Char.chr i in
+    (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$'
+  ) in
+  (fun c -> Array.unsafe_get a (Char.code c))
+
+(** Approximation could be improved *)
+let valid_ident (s : string) =
+  let len = String.length s in
+  valid_js_char s.[0] && valid_first_js_char s.[0] &&
+  (let module E = struct exception E end in
+   try
+     for i = 1 to len - 1 do
+       if not (valid_js_char (String.unsafe_get s i)) then
+         raise E.E         
+     done ;
+     true     
+   with E.E -> false )  
+  
+let valid_global_name ?loc txt =
+  let error () =
+    Location.raise_errorf ?loc "Not a valid  name %s"  txt  in
+  if txt = "" then
+    error ()
+  else
+    let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in
+    List.iter
+      (fun s ->
+         if not (valid_ident s) then error ()
+      ) v      
+
+let valid_method_name ?loc txt =         
+  let error () =
+    Location.raise_errorf ?loc "Not a valid  name %s"  txt  in
+  if not (valid_ident txt) then error ()
+
+
 let check_external_module_name ?loc x = 
   match x with 
   | {bundle = ""; _ } | {bind_name = Some ""} -> 
@@ -85,13 +130,12 @@ let check_external_module_name_opt ?loc x =
 
 let check_ffi ?loc ffi = 
   match ffi with 
-  | Js_global {txt = ""} 
-  | Js_send {name = ""}
-  | Js_set  ""
-  | Js_get ""
-    -> Location.raise_errorf ?loc "empty name encountered"
-  | Js_global _ | Js_send _ | Js_set _ | Js_get _  
-  | Obj_create _
+  | Js_global {txt} -> valid_global_name ?loc  txt 
+  | Js_send {name } 
+  | Js_set  name
+  | Js_get name
+    ->  valid_method_name ?loc name
+  | Obj_create _ -> ()
   | Js_get_index | Js_set_index 
     -> ()
 
@@ -101,10 +145,8 @@ let check_ffi ?loc ffi =
   | Js_new {external_module_name ; txt = name}
   | Js_call {external_module_name ; txt = {name ; _}}
     -> 
-    check_external_module_name_opt ?loc external_module_name ; 
-    if name = "" then
-      Location.raise_errorf ?loc "empty name in externals"
-
+    check_external_module_name_opt ?loc external_module_name ;
+    valid_global_name ?loc name     
 
 
 (** 

jscomp/test/.depend

@@ -269,6 +269,8 @@ gpr_459_test.cmj : mt.cmi
 gpr_459_test.cmx : mt.cmx
 gpr_627_test.cmj : mt.cmi
 gpr_627_test.cmx : mt.cmx
+gpr_658.cmj : ../runtime/js.cmj
+gpr_658.cmx : ../runtime/js.cmx
 guide_for_ext.cmj :
 guide_for_ext.cmx :
 hamming_test.cmj : ../stdlib/printf.cmi mt.cmi ../stdlib/lazy.cmi \
@@ -1041,6 +1043,8 @@ gpr_459_test.cmo : mt.cmi
 gpr_459_test.cmj : mt.cmj
 gpr_627_test.cmo : mt.cmi
 gpr_627_test.cmj : mt.cmj
+gpr_658.cmo : ../runtime/js.cmo
+gpr_658.cmj : ../runtime/js.cmj
 guide_for_ext.cmo :
 guide_for_ext.cmj :
 hamming_test.cmo : ../stdlib/printf.cmi mt.cmi ../stdlib/lazy.cmi \

jscomp/test/Makefile

@@ -60,7 +60,7 @@ OTHERS := literals a test_ari test_export2 test_internalOO test_obj_simple_ffi t
 	bs_rest_test infer_type_test fs_test module_as_function\
 	test_case_set test_mutliple string_bound_get_test inline_string_test\
 	ppx_this_obj_test unsafe_obj_external gpr_627_test jsoo_485_test jsoo_400_test	\
-	test_require more_uncurry earger_curry_test poly_type bench mutable_obj_test
+	test_require more_uncurry earger_curry_test poly_type bench mutable_obj_test gpr_658
 
 
 

jscomp/test/gpr_658.js

@@ -0,0 +1,5 @@
+'use strict';
+
+
+
+/* No side effect */

jscomp/test/gpr_658.ml

@@ -0,0 +1,8 @@
+
+
+
+(* external obj : < hi : int  > Js.t  = "{hi:1}" [@@bs.val] *)
+
+external mk : hi:int -> unit ->  < hi : int  > Js.t  = "" [@@bs.obj]
+
+(* external set_name : < > ->  string -> unit = "1name" [@@bs.set]  *)