Pārlūkot izejas kodu

minor remoting fixes
fixed Xml protect in flash8

Nicolas Cannasse 17 gadi atpakaļ
vecāks
revīzija
ce8339e0d2
4 mainītis faili ar 34 papildinājumiem un 13 dzēšanām
  1. 9 2
      codegen.ml
  2. 9 8
      genswf8.ml
  3. 3 1
      main.ml
  4. 13 2
      typeload.ml

+ 9 - 2
codegen.ml

@@ -51,6 +51,14 @@ let extend_remoting ctx c t p async prot =
 	ctx.com.package_rules <- PMap.foldi (fun key r acc -> match r with Forbidden -> acc | _ -> PMap.add key r acc) rules PMap.empty;
 	(* parse module *)
 	let path = (t.tpackage,t.tname) in
+	let new_name = (if async then "Async_" else "Remoting_") ^ t.tname in
+	(* check if the proxy already exists *)
+	let t = (try
+		Typeload.load_type_def ctx p (fst path,new_name)
+	with
+		Error (Module_not_found _,p2) when p == p2 ->
+	(* build it *)
+	if ctx.com.verbose then print_endline ("Building proxy for " ^ s_type_path path);
 	let decls = (try Typeload.parse_module ctx path p with e -> ctx.com.package_rules <- rules; raise e) in
 	ctx.com.package_rules <- rules;
 	let base_fields = [
@@ -89,7 +97,6 @@ let extend_remoting ctx c t p async prot =
 			(FFun (name,None,[APublic],pl,f),p) :: acc
 		| _ -> acc
 	in
-	let new_name = (if async then "Async_" else "Remoting_") ^ t.tname in
 	let decls = List.map (fun d ->
 		match d with
 		| EClass c, p when c.d_name = t.tname ->
@@ -99,7 +106,7 @@ let extend_remoting ctx c t p async prot =
 		| _ -> d
 	) decls in
 	let m = Typeload.type_module ctx (t.tpackage,new_name) decls p in
-	let t = (try 
+	try 
 		List.find (fun tdecl -> snd (t_path tdecl) = new_name) m.mtypes
 	with Not_found ->
 		error ("Module " ^ s_type_path path ^ " does not define type " ^ t.tname) p

+ 9 - 8
genswf8.ml

@@ -191,6 +191,7 @@ let unprotect a = !protect_all || a = "" || a = "_" || (a.[0] = '_' && a.[1] !=
 let rec is_protected_path path ext =
 	match path with
 	| ["flash"] , "Boot" | ["flash"] , "Lib" -> false
+	| ["flash"],"__FlashXml" -> true
 	| "flash" :: _ , _ | [] , "flash" -> ext
 	| [] , "Array" | [] , "Math" | [] , "Date" | [] , "String" | [] , "Bool" -> true
 	| [] , "Int" | [] , "Float" | [] , "Xml" -> true
@@ -351,7 +352,7 @@ let begin_func ctx need_super need_args args =
 			f_name = "";
 			Swf.f_args = List.map snd args;
 			f_codelen = 0;
-		} in		
+		} in
 		write ctx (AFunction f);
 		let start_pos = ctx.code_pos in
 		let old_stack = ctx.fun_stack in
@@ -462,7 +463,7 @@ let define_var ctx v ef exprs =
 let alloc_tmp ctx =
 	let r = alloc_reg ctx in
 	if ctx.flash6 then
-		let name = "$" ^ string_of_int r in		
+		let name = "$" ^ string_of_int r in
 		define_var ctx name None [];
 		TmpVar (name,r);
 	else
@@ -526,7 +527,7 @@ let rec gen_big_string ctx s =
 	if len <= max then
 		write ctx (APush [PString s])
 	else begin
-		write ctx (APush [PString (String.sub s 0 max)]);		
+		write ctx (APush [PString (String.sub s 0 max)]);
 		gen_big_string ctx (String.sub s max (len - max));
 		write ctx AAdd;
 	end
@@ -653,7 +654,7 @@ and gen_try_catch ctx retval e catchs =
 	List.iter (fun j -> j()) jumps;
 	end_try()
 
-and gen_switch ctx retval e cases def =	
+and gen_switch ctx retval e cases def =
 	gen_expr ctx true e;
 	let r = alloc_tmp ctx in
 	set_tmp ctx r;
@@ -861,7 +862,7 @@ and gen_call ctx e el =
 		push ctx [VNull];
 		write ctx AEqual;
 		let jump_end = cjmp ctx in
-		if e.eexpr = TLocal "__hkeys__" then begin			
+		if e.eexpr = TLocal "__hkeys__" then begin
 			push ctx [VInt 1; VInt 1; VReg 0; VStr ("substr",true)];
 			call ctx VarObj 1;
 		end else begin
@@ -1153,7 +1154,7 @@ let gen_enum_field ctx e f =
 		let rargs = List.map (fun (n,_,_) -> if no_reg then 0, n else alloc_reg ctx , "") args in
 		let nregs = List.length rargs + 2 in
 		let tf = begin_func ctx false false rargs in
-		List.iter (fun (r,name) -> 
+		List.iter (fun (r,name) ->
 			if no_reg then begin
 				push ctx [VStr (name,false)];
 				write ctx AEval;
@@ -1436,7 +1437,7 @@ let generate com =
 		curclass = null_class;
 		curmethod = ("",false);
 		fun_pargs = [];
-		in_loop = false;		
+		in_loop = false;
 	} in
 	write ctx (AStringPool []);
 	protect_all := not (Common.defined com "swf-mark");
@@ -1455,7 +1456,7 @@ let generate com =
 	let f = begin_func ctx false false [] in
 	push ctx [VStr ("xx",false); VThis; VInt 2];
 	getvar ctx (gen_path ctx (["flash"],"Boot") false);
-	push ctx [VStr ("__string_rec",false)]; 
+	push ctx [VStr ("__string_rec",false)];
 	call ctx VarObj 2;
 	write ctx AReturn;
 	f();

+ 3 - 1
main.ml

@@ -302,7 +302,9 @@ try
 				| x :: l -> (List.rev l,x)
 			) lines) @ !excludes;
 		),"<filename> : don't generate code for classes listed in this file");
-		("-v",Arg.Unit (fun () -> com.verbose <- true),": turn on verbose mode");
+		("-v",Arg.Unit (fun () -> 
+			if not !display then com.verbose <- true
+		),": turn on verbose mode");
 		("-debug", Arg.Unit (fun() -> Common.define com "debug"; com.debug <- true), ": add debug informations to the compiled code");
 		("-prompt", Arg.Unit (fun() -> prompt := true),": prompt on error");
 		("-cmd", Arg.String (fun cmd ->

+ 13 - 2
typeload.ml

@@ -49,7 +49,18 @@ let load_type_def ctx p tpath =
 	with
 		Not_found ->
 			let tpath, m = (try
-				if not no_pack || fst ctx.current.mpath = [] then raise Exit;
+				if not no_pack then raise Exit;
+				(match fst ctx.current.mpath with
+				| [] -> raise Exit
+				| x :: _ -> 
+					(* this can occur due to haxe remoting : a module can be
+						already defined in the "js" package and is not allowed
+						to access the js classes *)
+					try 
+						(match PMap.find x ctx.com.package_rules with
+						| Forbidden -> raise Exit
+						| _ -> ())
+					with Not_found -> ());
 				let tpath2 = fst ctx.current.mpath , snd tpath in
 				tpath2, ctx.api.load_module tpath2 p
 			with
@@ -872,7 +883,7 @@ let parse_module ctx m p =
 		| x :: l , name ->
 			let x = (try
 				match PMap.find x ctx.com.package_rules with
-				| Forbidden -> error ("You can't access the " ^ x ^ " package with current compilation flags") p;
+				| Forbidden -> error ("You can't access the " ^ x ^ " package with current compilation flags (for " ^ s_type_path m ^ ")") p;
 				| Directory d -> d
 				with Not_found -> x
 			) in