*** empty log message ***

1 files changed, 191 insertions, 132 deletions

diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml
index 33cc111..e91e0e1 100644
--- a/perl_checker.src/tree.ml
+++ b/perl_checker.src/tree.ml
@@ -1,12 +1,15 @@
 open Types
 open Common
 open Printf
+open Parser_helper
+
+type special_export = Re_export_all | Export_all
 
 type exports = { 
     export_ok : (context * string) list ;
     export_auto : (context * string) list ;
     export_tags : (string * (context * string) list) list ;
-    re_export_all : bool ;
+    special_export : special_export option ;
   }
 
 type uses = (string * ((context * string) list option * pos)) list
@@ -15,12 +18,14 @@ type per_package = {
     file_name : string ;
     package_name : string ; has_package_name : bool ;
     vars_declared : (context * string, pos) Hashtbl.t ;
+    imported : ((context * string) * string) list option ref ;
     exports : exports ;
     uses : uses ;
     body : fromparser list;
   }
 type state = {
     per_package : (string * per_package) list ;
+    files_parsed : string list ;
     global_vars_declared : (context * string * string, pos) Hashtbl.t ;
     global_vars_used : ((context * string * string) * pos) list ref ;
   }
@@ -28,28 +33,20 @@ type state = {
 type vars = { 
     my_vars : (context * string) list list ;
     our_vars : (context * string) list list ;
-    imported : ((context * string) * string) list ;
+    locally_imported : ((context * string) * string) list ;
     required_vars : (context * string * string) list ;
     current_package : per_package ;
     state : state ;
   }
 
 let anonymous_package_count = ref 0
-let default_state = { per_package = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] }
-let empty_exports = { export_ok = []; export_auto = []; export_tags = []; re_export_all = false }
+let default_state = { per_package = []; files_parsed = []; global_vars_declared = Hashtbl.create 256; global_vars_used = ref [] }
+let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None }
 let ignored_packages = ref []
 
 let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg)
 let warn_with_pos pos msg = prerr_endline (Info.pos2sfull pos ^ msg)
 
-let context2s = function
-  | I_scalar -> "$"
-  | I_hash -> "%"
-  | I_array -> "@"
-  | I_func -> "&"
-  | I_raw -> ""
-  | I_star -> "*"
-let variable2s(context, ident) = context2s context ^ ident
 let s2context s = 
   match s.[0] with
   | '$' -> I_scalar, skip_n_char 1 s
@@ -63,14 +60,22 @@ let s2context s =
 
 let get_current_package t =
   match t with
-  | Package(Ident _ as ident) :: _ -> 
-      Some (Parser_helper.string_of_Ident ident)
+  | Package(Ident _ as ident) :: body ->
+      let rec bundled_packages packages current_package found_body = function
+	| [] -> (Some current_package, List.rev found_body) :: packages
+	| Package(Ident _ as ident) :: body ->
+	    let packages = (Some current_package, List.rev found_body) :: packages in
+	    bundled_packages packages (string_of_Ident ident) [] body
+	| instr :: body ->
+	    bundled_packages packages current_package (instr :: found_body) body
+      in
+      bundled_packages [] (string_of_Ident ident) [] body
   | _ -> 
       if str_ends_with !Info.current_file ".pm" then warn_with_pos (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" !Info.current_file) ;
-      None
+      [ None, t ]
 
 let from_qw = function
-  | Call_op("qw", [ Raw_string(s, pos)]) -> 
+  | Call_op("qw", [ Raw_string(s, pos)], _) -> 
       List.map (fun s -> 
 	let context, s' = s2context s in
 	let context =
@@ -88,20 +93,21 @@ let from_qw = function
 let get_exported t =
   List.fold_left (fun exports e ->
     match e with
-    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); Call _ ]) ]
-    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos);  Call _ ]) ] ->
-	if not exports.re_export_all then warn_with_pos pos "unrecognised @EXPORT" ;
+    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); Call _ ], pos) ]
+    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _);  Call _ ], pos) ] ->
+	if exports.special_export = None then warn_with_pos pos "unrecognised @EXPORT" ;
 	exports
 
-    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", pos)); v ])]
-    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], pos); v ])] ->
+    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); v ], pos)]
+    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); v ], pos)] ->
 	if exports.export_auto <> [] then warn_with_pos pos "weird, @EXPORT set twice" ;
 	{ exports with export_auto = from_qw v }
 
-    | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with re_export_all = true }
+    | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all }
+    | Perl_checker_comment("EXPORT-ALL",    _) -> { exports with special_export = Some Export_all }
 
-    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", pos)); v ])]
-    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], pos);  v ])] ->
+    | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)]
+    | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _);  v ], pos)] ->
 	if exports.export_ok <> [] then warn_with_pos pos "weird, @EXPORT_OK set twice" ;
 	(match v with
 	| Call(Deref(I_func, Ident(None, "map", _)), 
@@ -110,8 +116,8 @@ let get_exported t =
 		   { exports with export_ok = collect snd exports.export_tags }
 	| _ -> { exports with export_ok = from_qw v })
 
-    | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", pos)); v ])]
-    | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], pos);  v ])] ->
+    | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _)); v ], pos)]
+    | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], _);  v ], pos)] ->
 	(try
 	  let export_tags =
 	    match v with
@@ -147,9 +153,9 @@ let uses_external_package = function
 let get_uses t =
   List.fold_left (fun uses e ->
     match e with
-    | Use(Ident _ as pkg, _) when uses_external_package (Parser_helper.string_of_Ident pkg) -> uses
+    | Use(Ident _ as pkg, _) when uses_external_package (string_of_Ident pkg) -> uses
     | Use(Ident(_, _, pos) as ident, l) ->
-	let package = Parser_helper.string_of_Ident ident in
+	let package = string_of_Ident ident in
 	let para = if l = [] then None else Some(from_qw (List.hd l)) in
 	(package, (para, pos)) :: uses
     | _ -> uses
@@ -162,7 +168,7 @@ let get_vars_declaration state package =
     | Sub_declaration(Ident(Some fq, name, pos), _proto, _) ->
 	Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos
 
-    | List [ Call_op("=", [My_our("our", ours, pos); _]) ]
+    | List [ Call_op("=", [My_our("our", ours, pos); _], _) ]
     | List [ My_our("our", ours, pos) ]
     | My_our("our", ours, pos) ->
 	List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) ours
@@ -171,38 +177,71 @@ let get_vars_declaration state package =
     | Use(Ident(None, "vars", pos), [ours]) -> 
 	List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) pos) (from_qw ours)
     | Use(Ident(None, "vars", pos), _) -> 
-	die_with_pos pos "usage: \"use vars qw($var func)\""
+	die_with_pos pos "usage: use vars qw($var func)"
+
+    | List [ Method_call(Raw_string(pkg, pos), Raw_string("bootstrap", _), _) ] ->
+	if pkg <> package.package_name then
+	  warn_with_pos pos "strange bootstrap (the package name is not the same as the current package)"
+	else
+	  (try
+	    let cfile = Filename.chop_extension package.file_name ^ ".c" in
+	    let prefix = "newXS(\"" ^ pkg ^ "::" in
+	    ignore (fold_lines (fun in_bootstrap s ->
+	      if in_bootstrap then
+		(try
+		  let offset = strstr s prefix + String.length prefix in
+		  let end_ = String.index_from s offset '"' in
+		  let ident = String.sub s offset (end_ - offset) in
+		  match split_at2 ':'':' ident with
+		  | [_] -> Hashtbl.replace package.vars_declared (I_func, ident) pos
+		  | l -> 
+		      if l <> [] then
+			let fql, name = split_last l in
+			let fq = String.concat "::" (pkg :: fql) in
+			Hashtbl.replace state.global_vars_declared (I_func, fq, name) pos	
+		with Not_found -> ());
+	      in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK"
+	    ) false (open_in cfile))
+	  with Invalid_argument _ | Sys_error _ -> ())
     | _ -> ()
   ) package.body
 
-let get_imports state package =
-  let rec get_one (package_name, (imports, pos)) =
-    try
-      let package_used = List.assoc package_name state.per_package in
-      let exports = package_used.exports in
-      match imports with
-      | None ->
-	  let re = if exports.re_export_all then collect get_one package_used.uses else [] in
-	  let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in
-	  re @ l
-      | Some l -> 
-	  let imports_vars = 
-	    collect (function
-	      | I_raw, tag -> 
-		  (try 
-		    List.assoc tag exports.export_tags
-		  with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag))
-	      | variable ->
-		  if List.mem variable exports.export_ok then
-		    [ variable ]
-		  else
-		    die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable))
-		    ) l
-	  in
-	  List.map (fun (context, name) -> (context, name), package_name) imports_vars
-    with Not_found -> []
-  in
-  collect get_one package.uses
+let rec get_imported state (package_name, (imports, pos)) =
+  try
+    let package_used = List.assoc package_name state.per_package in
+    let exports = package_used.exports in
+    match imports with
+    | None ->
+	let re = match exports.special_export with
+	| Some Re_export_all -> get_imports state package_used
+	| Some Export_all -> Hashtbl.fold (fun var _ l -> (var, package_name) :: l) package_used.vars_declared []
+	| _ -> [] in
+	let l = List.map (fun (context, name) -> (context, name), package_name) exports.export_auto in
+	re @ l
+    | Some l -> 
+	let imports_vars = 
+	  collect (function
+	    | I_raw, tag -> 
+		(try 
+		  List.assoc tag exports.export_tags
+		with Not_found -> die_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag))
+	    | variable ->
+		if List.mem variable exports.export_ok then
+		  [ variable ]
+		else
+		  die_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable))
+		  ) l
+	in
+	List.map (fun (context, name) -> (context, name), package_name) imports_vars
+  with Not_found -> []
+
+and get_imports state package =
+  match !(package.imported) with
+  | Some l -> l
+  | None ->
+      let l = collect (get_imported state) package.uses in
+      package.imported := Some l ;
+      l
 
 let rec fold_tree f env e = 
   match f env e with
@@ -218,8 +257,7 @@ let rec fold_tree f env e =
        -> fold_tree_option f env e'
 
   | Sub_declaration(e1, _, e2)
-  | Deref_with(_, e1, e2)
-  | Binop(_, e1, e2)
+  | Deref_with(_, _, e1, e2)
        -> 
 	 let env = fold_tree f env e1 in
 	 let env = fold_tree f env e2 in
@@ -228,31 +266,20 @@ let rec fold_tree f env e =
   | Use(_, l)
   | List l
   | Block l
-  | Call_op(_, l)
+  | Call_op(_, l, _)
       -> List.fold_left (fold_tree f) env l
 
   | Call(e', l)
-  | CallP(e', l)
     -> 
       let env = fold_tree f env e' in
       List.fold_left (fold_tree f) env l
 
   | Method_call(e1, e2, l)
-  | Method_callP(e1, e2, l)
     ->
       let env = fold_tree f env e1 in
       let env = fold_tree f env e2 in
       List.fold_left (fold_tree f) env l
 
-  | If_then_else(_, t_l, e') 
-    -> 
-      let env = fold_tree_option f env e' in
-      List.fold_left (fun env (e1, e2) -> 
-	let env = fold_tree f env e1 in
-	let env = fold_tree f env e2 in
-	env
-      ) env t_l
-
   | _ -> env
 
 and fold_tree_option f env = function
@@ -261,45 +288,50 @@ and fold_tree_option f env = function
 
 
 let get_global_info_from_package t =
-  let exports = get_exported t in
-  let uses = get_uses t in
-  let current_package = get_current_package t in
-  let package_name =
-    match current_package with
-    | None -> 
-	if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then
-	  die_with_pos (!Info.current_file, 0, 0) "file with no \"package\" wants to export!"
-	else
-	  (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count)
-    | Some name -> name
-  in
-  let required_packages = List.fold_left (fold_tree (fun l -> 
-    function
-      | Call(Deref(I_func, Ident (None, "require", pos)), [Raw_string (package, _)])
-	  when not (uses_external_package package) -> Some((package, pos) :: l)
-      | _ -> None)
-  ) [] t in
-  required_packages, { 
-    file_name = !Info.current_file ; 
-    package_name = package_name;
-    has_package_name = current_package <> None ;
-    exports = exports ;
-    vars_declared = Hashtbl.create 16 ;
-    uses = uses ;
-    body = t ;
-  }
-
+  let current_packages = get_current_package t in
+  map_withenv (fun required_packages (current_package, t) ->
+    let exports = get_exported t in
+    let uses = get_uses t in
+    let package_name =
+      match current_package with
+      | None -> 
+	  if exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] then
+	    die_with_pos (!Info.current_file, 0, 0) "file with no package name wants to export!"
+	  else
+	    (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count)
+      | Some name -> name
+    in
+    let required_packages = List.fold_left (fold_tree (fun l -> 
+      function
+	| Call(Deref(I_func, Ident (None, "require", pos)), [Ident _ as pkg]) ->
+	    let package = string_of_Ident pkg in
+	    if uses_external_package package then None else Some((package, pos) :: l)
+	| _ -> None)
+      ) required_packages t in
+    { 
+      file_name = !Info.current_file ; 
+      package_name = package_name;
+      has_package_name = current_package <> None ;
+      exports = exports ;
+      imported = ref None ;
+      vars_declared = Hashtbl.create 16 ;
+      uses = uses ;
+      body = t ;
+    }, required_packages
+  ) [] current_packages
 
 let is_my_declared vars t = List.exists (List.exists ((=) t)) vars.my_vars
 let is_our_declared vars t = List.exists (List.exists ((=) t)) vars.our_vars
 let is_var_declared vars (context, name) = 
-  List.mem_assoc (context, name) vars.imported ||
+  List.mem_assoc (context, name) vars.locally_imported ||
+  List.mem_assoc (context, name) (get_imports vars.state vars.current_package) ||
   Hashtbl.mem vars.current_package.vars_declared (context, name)
 let is_global_var_declared vars (context, fq, name) =
   Hashtbl.mem vars.state.global_vars_declared (context, fq, name) ||
   (try
     let package = List.assoc fq vars.state.per_package in
-    Hashtbl.mem package.vars_declared (context, name)
+    Hashtbl.mem package.vars_declared (context, name) ||
+    List.mem_assoc (context, name) (get_imports vars.state package)
   with Not_found -> false)
 
  
@@ -358,7 +390,7 @@ let check_variable (context, var) vars =
       then ()
       else 
 	if context = I_func then 
-	  warn_with_pos pos ("unknown function " ^ Parser_helper.string_of_Ident var)
+	  warn_with_pos pos ("unknown function " ^ string_of_Ident var)
 	else
 	  lpush vars.state.global_vars_used ((context, fq, name), pos)
   | _ -> ()
@@ -366,12 +398,12 @@ let check_variable (context, var) vars =
 let declare_My vars (mys, pos) =
   let l_new = List.filter (fun (context, ident) ->
     if context = I_raw then
-      if ident = "undef" then false else die_with_pos pos (sprintf "bad ident \"%s\" in my" ident)
+      if ident = "undef" then false else die_with_pos pos (sprintf "bad ident %s in my" ident)
     else true
   ) mys in
   let l_pre = List.hd vars.my_vars in
   List.iter (fun v ->
-    if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v))
+    if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v))
   ) l_new ;
   { vars with my_vars = (l_new @ l_pre) :: List.tl vars.my_vars }
 
@@ -380,7 +412,7 @@ let declare_Our vars (ours, pos) =
   | [] -> vars (* we're at the toplevel, already declared in vars_declared *)
   | l_pre :: other ->
       List.iter (fun v ->
-	if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable \"%s\"" (variable2s v))
+	if List.exists ((=) v) l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v))
       ) ours ;
       { vars with our_vars = (ours @ l_pre) :: other }
 
@@ -405,11 +437,11 @@ let check_variables vars t =
 	let _vars' = List.fold_left check_variables_ vars' f in
 	Some vars
 
-    | Call_op("foreach my", [my; expr; Block block]) ->
+    | Call_op("foreach my", [my; expr; Block block], _) ->
 	let vars = check_variables_ vars expr in
 	let vars = check_variables_ vars (Block (my :: block)) in
 	Some vars
-    | Call_op(op, cond :: Block first_bl :: other) when op = "if" || op = "while" || op = "unless" || op = "until" ->
+    | Call_op(op, cond :: Block first_bl :: other, _) when op = "if" || op = "while" || op = "unless" || op = "until" ->
 	let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [] :: vars.our_vars } in
 	let vars' = check_variables_ vars' cond in
 	let _vars' = List.fold_left check_variables_ vars' first_bl in
@@ -417,7 +449,7 @@ let check_variables vars t =
 	Some vars
 
     | Sub_declaration(Ident(_, _, pos) as ident, _proto, body) ->
-	let vars = declare_Our vars ([ I_func, Parser_helper.string_of_Ident ident ], pos) in
+	let vars = declare_Our vars ([ I_func, string_of_Ident ident ], pos) in
 	let vars = check_variables_ vars body in
 	Some vars
 
@@ -429,31 +461,37 @@ let check_variables vars t =
     | Deref(context, (Ident _ as var)) -> 
 	check_variable (context, var) vars ;
 	Some vars
-    | Deref_with(context, (Ident _ as var), para) -> 
+    | Deref_with(context, _, (Ident _ as var), para) -> 
 	let vars = check_variables_ vars para in
 	check_variable (context, var) vars ;
 	Some vars
 
-    | Call_op(op, [My_our(my_or_our, mys, pos); e]) ->
-	if op = "=" then
-	  (* check e first *)
-	  let vars = check_variables_ vars e in
-	  List.iter (fun (context, var) ->
-	    if context = I_hash || context = I_array then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys)))
-	  ) (removelast mys) ; (* mys is never empty *)
-	  Some(declare_My_our vars (my_or_our, mys, pos))
-	else
-	  (warn_with_pos pos "weird" ; None)
-
-    | Call(Deref(I_func, Ident(None, "require", _)), [Raw_string (package_name, _)]) ->
-	(try
-	  let package = List.assoc package_name vars.state.per_package in
-	  let required_vars = Hashtbl.fold (fun (context, ident) _ l -> 
-	    (context, vars.current_package.package_name, ident) :: l
-	  ) package.vars_declared vars.required_vars in
-	  let vars = { vars with required_vars = required_vars } in
-	  Some vars
-	with Not_found -> Some vars)
+    | Call_op("=", [My_our(my_or_our, mys, pos); e], _) ->
+	(* check e first *)
+	let vars = check_variables_ vars e in
+	List.iter (fun (context, var) ->
+	  if non_scalar_context context then die_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys)))
+	) (removelast mys) ; (* mys is never empty *)
+	Some(declare_My_our vars (my_or_our, mys, pos))
+
+    | Call_op("if infix", [List [My_our _]; List [Num("0", _)]], _) -> None (* special allowed case *)
+    | Call_op(op, List (My_our _ :: _) :: _, pos) 
+    | Call_op(op, My_our _ :: _, pos)
+    | Call_op(op, Call_op("local", _, _) :: _, pos) ->
+	if op <> "=" then warn_with_pos pos (sprintf "applying %s on a new initialized variable is wrong" op);
+	None
+
+    | Call(Deref(I_func, Ident(None, "require", _)), [Ident _]) -> Some vars
+
+    | Method_call(Raw_string(package_name, pos), Raw_string ("import", _), para) ->
+	let args =
+	  match para with
+	  | [] -> None
+	  | [ List [v] ] -> Some(from_qw v)
+	  | _ -> die_with_pos pos "bad import statement" in
+	let l = get_imported vars.state (package_name, (args, pos)) in
+	let vars = { vars with locally_imported = l @ vars.locally_imported } in
+	Some vars
 	
     | _ -> None
   in
@@ -461,7 +499,28 @@ let check_variables vars t =
   vars
 
 let check_tree state package =
-  let imports = get_imports state package in
-  let vars = { my_vars = [[]]; our_vars = []; imported = imports; required_vars = []; current_package = package; state = state } in
+  let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state } in
   let _vars = check_variables vars package.body in
   ()
+
+let add_package_to_state state package = 
+  let per_package =
+    try
+      update_assoc (fun existing_package ->
+	(*prerr_endline (existing_package.file_name ^ " vs " ^ package.file_name); *)
+	Hashtbl.iter (fun var pos -> Hashtbl.replace existing_package.vars_declared var pos) package.vars_declared ;
+	{ existing_package with
+	  body = existing_package.body @ package.body ;
+	  uses = existing_package.uses @ package.uses ;
+	  exports = { export_ok   = existing_package.exports.export_ok   @ package.exports.export_ok ;
+		      export_auto = existing_package.exports.export_auto @ package.exports.export_auto ;
+		      export_tags = existing_package.exports.export_tags @ package.exports.export_tags ;
+		      special_export = None }
+	}
+      ) package.package_name state.per_package
+  with Not_found ->
+    (package.package_name, package) :: state.per_package
+  in
+  { state with 
+    per_package = per_package ; 
+    files_parsed = package.file_name :: state.files_parsed }