Rename folder to match history.

This is a Synthesized commit to combine perl-MDK-Common and perl_checker repository
history.

1 files changed, 443 insertions, 0 deletions

diff --git a/src/tree.ml b/src/tree.ml
new file mode 100644
index 0000000..16fd0e4
--- /dev/null
+++ b/src/tree.ml
@@ -0,0 +1,443 @@
+open Types
+open Common
+open Printf
+open Config_file
+open Parser_helper
+
+type special_export = Re_export_all | Fake_export_all
+
+type exports = { 
+    export_ok : (context * string) list ;
+    export_auto : (context * string) list ;
+    export_tags : (string * (context * string) list) list ;
+    special_export : special_export option ;
+  }
+
+type uses = (string * ((context * string) list option * pos)) list
+
+type prototype = {
+    proto_nb_min : int ;
+    proto_nb_max : int option ;
+  }
+
+type variable_used = Access_none | Access_write_only | Access_various
+
+type per_package = {
+    package_name : string ; has_package_name : bool ;
+    vars_declared : (context * string, pos * variable_used ref * prototype option) Hashtbl.t;
+    imported : ((context * string) * (string * variable_used ref * prototype option)) list option ref;
+    exports : exports ;
+    uses : uses ;
+    required_packages : (string * pos) list ;
+    body : fromparser list;
+    isa : (string * pos) list option ;
+  }
+
+type per_file = {
+    file_name : string ;
+    require_name : string option ;
+    lines_starts : int list ;
+    build_time : float ;
+    packages : per_package list ;
+    from_basedir : bool ;
+  }
+
+let anonymous_package_count = ref 0
+let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None }
+let use_lib = ref (List.map Info.file_to_absolute_file (readlines (Unix.open_process_in "perl -le 'print foreach @INC'")))
+
+let ignore_package pkg = 
+  if !Flags.verbose then print_endline_flush ("ignoring package " ^ pkg);
+  lpush ignored_packages pkg
+
+let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg)
+let warn_with_pos warn_types pos msg = if Flags.are_warning_types_set warn_types then print_endline_flush (Info.pos2sfull pos ^ msg)
+
+let s2context s = 
+  match s.[0] with
+  | '$' -> I_scalar, skip_n_char 1 s
+  | '%' -> I_hash  , skip_n_char 1 s
+  | '@' -> I_array , skip_n_char 1 s
+  | '&' -> I_func  , skip_n_char 1 s
+  | '*' -> I_star  , skip_n_char 1 s
+  | _ -> I_raw, s
+
+
+let get_current_package t =
+  match t with
+  | Package(Ident _ as ident) :: body ->
+      let rec bundled_packages packages current_package found_body = function
+	| [] -> List.rev ((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_fromparser ident) [] body
+	| instr :: body ->
+	    bundled_packages packages current_package (instr :: found_body) body
+      in
+      bundled_packages [] (string_of_fromparser ident) [] body
+  | _ -> 
+      if str_ends_with !Info.current_file ".pm" then warn_with_pos [Warn_normalized_expressions] (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" (Info.absolute_file_to_file !Info.current_file)) ;
+      [ None, t ]
+
+let from_qw_raw = function
+  | String([s, List []], pos) -> [ s, pos ]
+  | String(_, pos) ->
+      warn_with_pos [] pos "not recognised yet" ;
+      []
+  | Raw_string(s, pos) ->
+      [ s, pos ]
+  | List [] -> []
+  | List [ List l ] ->
+      some_or (l_option2option_l (List.map (function
+	| String([s, List []], pos)
+	| Raw_string(s, pos) -> Some(s, pos)
+	| Ident(_, _, pos) as ident -> Some(string_of_fromparser ident, pos)
+	| e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; None
+      ) l)) []
+  | e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; []
+
+let from_qw e =
+  List.map (fun (s, pos) -> 
+    let context, s' = s2context s in
+    let context =
+      match context with
+      | I_raw -> if s'.[0] = ':' then I_raw else I_func
+      | I_func -> warn_with_pos [Warn_import_export] pos "weird, exported name with a function context especially given"; I_func
+      | _ -> context 
+    in context, s'
+  ) (from_qw_raw e)
+
+let get_exported t =
+  List.fold_left (fun exports e ->
+    match e with
+    | 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 [Warn_import_export] pos "unrecognised @EXPORT" ;
+	exports
+
+    | 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 [Warn_import_export] pos "weird, @EXPORT set twice" ;
+	{ exports with export_auto = from_qw v }
+
+    | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all }
+    | Perl_checker_comment("EXPORT-ALL",    _) -> { exports with special_export = Some Fake_export_all }
+
+    | 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 [Warn_import_export] pos "weird, @EXPORT_OK set twice" ;
+	(match v with
+	| Call(Deref(I_func, Ident(None, "map", _)), 
+	       [ Anonymous_sub(_, Block [List [Deref(I_array, Deref(I_scalar, Ident (None, "_", _)))]], _);
+		 Call(Deref(I_func, Ident(None, "values", _)), [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _))])]) ->
+		   { 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", _)); v ], pos)]
+    | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], _);  v ], pos)] ->
+	(try
+	  let export_tags =
+	    match v with
+	    | List [ List l ] ->
+		List.map (function
+		  | Raw_string(tag, _), Ref(I_array, List [List [v]]) ->
+		      let para =
+			match v with
+			| Deref(I_array, Ident(None, "EXPORT_OK", _)) -> exports.export_ok
+			| _ -> from_qw v
+		      in
+		      ":" ^ tag, para
+		  | _ -> raise Not_found
+	        ) (group_by_2 l)
+	    | _ -> raise Not_found
+	  in
+	  if exports.export_tags <> [] then warn_with_pos [Warn_import_export] pos "weird, %EXPORT_TAGS set twice" ;
+	  { exports with export_tags = export_tags }
+	with _ ->
+	  warn_with_pos [Warn_import_export] pos "unrecognised %EXPORT_TAGS" ;
+	  exports)
+
+      (* $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ]; *)
+    | List [Call_op("=", [
+		    Deref_with(I_hash, I_scalar, Ident(None, "EXPORT_TAGS", _), Raw_string("all", _));
+		    Ref(I_array,
+			List[List[
+			     Call(Deref(I_func, Ident(None, "map", _)),
+				  [Anonymous_sub(_, Block [List [Deref(I_array, Deref(I_scalar, Ident(None, "_", _)))]], _);
+				   Call(Deref(I_func, Ident(None, "values", _)), [Deref(I_hash, Ident(None, "EXPORT_TAGS", _))])])
+			   ]])
+		  ], _)] ->
+		    { exports with export_tags = (":all", collect snd exports.export_tags) :: exports.export_tags }
+
+    | List (My_our _ :: _) ->
+	let _,_ = e,e in
+	exports
+    | _ -> exports
+  ) empty_exports t
+
+let uses_external_package = function
+  | "vars" | "Exporter" | "diagnostics" | "strict" | "warnings" | "lib" | "POSIX" | "Gtk" | "Storable"
+  | "Config" | "Socket" | "IO::Socket" | "DynaLoader" | "Data::Dumper" | "Time::localtime" | "Expect" -> true
+  | _ -> false
+
+let get_uses t =
+  List.fold_left (fun uses e ->
+    match e with
+    | Use(Ident(None, "lib", _), [libs]) ->
+	use_lib := List.map Info.file_to_absolute_file (List.map snd (from_qw libs)) @ !use_lib ;
+	uses
+    | Use(Ident(None, "base", _), classes) ->
+	let l = List.map (fun (pkg, pos) -> (pkg, (None, pos))) (collect from_qw_raw classes) in
+	l @ uses
+    | Use(Ident(_, _, pos) as pkg, l) ->
+	let package = string_of_fromparser pkg in
+	if uses_external_package package then
+	  uses
+	else
+	  let para = match l with
+	  | [] -> None
+	  | [ Num(_, _) ] -> None (* don't care about the version number *)
+	  | _ -> Some(collect from_qw l)
+	  in
+	  (package, (para, pos)) :: uses
+    | _ -> uses
+  ) [] t
+
+let get_isa t =
+  List.fold_left (fun (isa, exporter) e ->
+    match e with
+    | Use(Ident(None, "base", pos), classes) ->
+	if isa <> None || exporter <> None then die_with_pos pos "\"use base\" and \"@ISA\" must be used once only";
+	Some (collect from_qw_raw classes), None
+    | List [ Call_op("=", [ Deref(I_array, Ident(None, "ISA", pos)) ; classes ], _) ]
+    | List [ Call_op("=", [ My_our("our", [ I_array, "ISA" ], pos) ; classes ], _) ] ->
+	if isa <> None || exporter <> None then die_with_pos pos "\"use base\" and \"@ISA\" must be used once only";
+	let special, l = List.partition (fun (s, _) -> s = "DynaLoader" || s = "Exporter") (from_qw_raw classes) in
+	let exporter = if List.mem_assoc "Exporter" special then Some pos else None in
+	let isa = if l = [] && special <> [] then None else Some l in
+	isa, exporter
+    | _ -> isa, exporter
+  ) (None, None) t
+
+let read_xs_extension_from_c global_vars_declared file_name package pos =
+  try
+    let cfile = Filename.chop_extension file_name ^ ".c" in
+    let prefix = "newXS(\"" ^ package.package_name ^ "::" 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_name_or_fq_name ident with
+	  | None, ident -> Hashtbl.replace package.vars_declared (I_func, ident) (pos, ref Access_none, None)
+	  | Some fq, ident -> 
+	      let fq = package.package_name ^ "::" ^ fq in
+	      Hashtbl.replace global_vars_declared (I_func, fq, ident) (pos, None)
+	 with Not_found -> ());
+      in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK"
+    ) false (open_in cfile));
+    if !Flags.verbose then print_endline_flush (sprintf "using xs symbols from %s" cfile) ;
+    true
+  with Invalid_argument _ | Sys_error _ -> false
+
+let findfile dirs f = List.find (fun dir -> Sys.file_exists (dir ^ "/" ^ f)) dirs
+
+let read_xs_extension_from_so global_vars_declared package pos =
+  try
+    let splitted = split_at2 ':'':' package.package_name in
+    let rel_file = String.concat "/" ("auto" :: splitted @ [ last splitted ]) ^ ".so" in
+    let so = (findfile !use_lib rel_file) ^ "/" ^ rel_file in
+    let channel = Unix.open_process_in (Printf.sprintf "nm --defined-only -D \"%s\"" so) in
+    if !Flags.verbose then print_endline_flush (sprintf "using shared-object symbols from %s" so) ;
+    fold_lines (fun () s ->
+      let s = skip_n_char 11 s in
+      if str_begins_with "XS_" s then
+	let s = skip_n_char 3 s in
+	let len = String.length s in
+	let rec find_package_name accu i =
+	  try
+	    let i' = String.index_from s i '_' in
+	    let accu = String.sub s i (i'-i) :: accu in
+	    if i' + 1 < len && s.[i'+1] = '_' then
+	      find_package_name accu (i' + 2)
+	    else
+	      List.rev accu, skip_n_char (i'+1) s
+	  with Not_found -> List.rev accu, skip_n_char i s
+	in
+	let fq, name = find_package_name [] 0 in
+	Hashtbl.replace global_vars_declared (I_func, String.concat "::" fq, name) (pos, None)
+    ) () channel;
+    if not Build.debugging then ignore (Unix.close_process_in channel) ;
+    true
+  with Not_found -> false
+
+let has_proto perl_proto body = 
+  match perl_proto with
+  | Some "" -> Some([], raw_pos2pos bpos, [body])
+  | _ -> 
+      match body with
+      | Block [] ->
+	  Some([ I_array, "_empty" ], raw_pos2pos bpos, [])
+      | Block (List [Call_op ("=", [My_our ("my", mys, mys_pos); Deref(I_array, Ident(None, "_", _))], _pos)] :: body) ->
+	  Some(mys, mys_pos, body)
+      | _ -> None
+
+let get_proto perl_proto body =
+  map_option (fun (mys, pos, _) ->
+    let scalars, others = break_at (fun (context, _) -> context <> I_scalar) mys in
+    (match others with
+    | (I_array, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an array must be the last variable in a prototype"
+    | (I_hash, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an hash must be the last variable in a prototype"
+    | _ -> ());
+    let is_optional (_, s) = 
+      String.length s > 2 &&                (s.[0] = 'o' || s.[0] = 'b') && s.[1] = '_' ||
+      String.length s > 3 && s.[0] = '_' && (s.[1] = 'o' || s.[1] = 'b') && s.[2] = '_'
+    in
+    let must_have, optional = break_at is_optional scalars in
+    if not (List.for_all is_optional optional) then
+      warn_with_pos [Warn_prototypes] pos "an non-optional argument must not follow an optional argument";
+    let min = List.length must_have in    
+    { proto_nb_min = min; proto_nb_max = if others = [] then Some(min + List.length optional) else None }
+  ) (has_proto perl_proto body)
+
+let get_vars_declaration global_vars_declared file_name package = 
+  List.iter (function
+    | Sub_declaration(Ident(None, name, pos), perl_proto, body, _) ->
+	Hashtbl.replace package.vars_declared (I_func, name) (pos, ref Access_none, get_proto perl_proto body)
+    | Sub_declaration(Ident(Some fq, name, pos), perl_proto, body, _) ->
+	Hashtbl.replace global_vars_declared (I_func, fq, name) (pos, get_proto perl_proto body)
+
+    | List [ Call_op("=", [My_our("our", ours, pos); _], _) ]
+    | List [ Call_op("=", [My_our("local", ([ I_scalar, "_" ] as 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, ref Access_none, None)) ours
+
+    | Use(Ident(None, "vars", pos), [ours]) -> 
+	List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) (pos, ref Access_none, None)) (from_qw ours)
+    | Use(Ident(None, "vars", pos), _) -> 
+	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 [Warn_import_export] pos "strange bootstrap (the package name is not the same as the current package)"
+	else
+	  if not (read_xs_extension_from_c global_vars_declared file_name package pos) then 
+	    if not (read_xs_extension_from_so global_vars_declared package pos) then
+	      ignore_package pkg
+    | _ -> ()
+  ) package.body
+
+let rec fold_tree f env e = 
+ match f env e with
+  | Some env -> env
+  | None ->
+  match e with
+  | Anonymous_sub(_, e', _)
+  | Ref(_, e')
+  | Deref(_, e')
+    -> fold_tree f env e'
+
+  | Diamond(e')
+    -> fold_tree_option f env e'
+
+  | String(l, _)
+    -> List.fold_left (fun env (_, e) -> fold_tree f env e) env l
+
+  | Sub_declaration(e1, _, e2, _)
+  | Deref_with(_, _, e1, e2)
+    -> 
+      let env = fold_tree f env e1 in
+      let env = fold_tree f env e2 in
+      env
+
+  | Use(_, l)
+  | List l
+  | Block l
+  | Call_op(_, l, _)
+    -> List.fold_left (fold_tree f) env l
+
+  | Call(e', l)
+    -> 
+      let env = fold_tree f env e' in
+      List.fold_left (fold_tree f) env l
+
+  | Method_call(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
+
+  | _ -> env
+
+and fold_tree_option f env = function
+  | None -> env
+  | Some e -> fold_tree f env e
+
+
+let get_global_info_from_package from_basedir require_name build_time t =
+  let current_packages = get_current_package t in
+  let packages = List.map (fun (current_package, t) ->
+    let exports = get_exported t in
+    let exporting_something() = exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] || exports.special_export = Some Re_export_all in
+
+    let package_name =
+      match current_package with
+      | None -> 
+	  if exporting_something() 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 isa, exporter = get_isa t in
+    (match exporter with
+    | None ->
+	if exporting_something() then warn_with_pos [Warn_import_export] (!Info.current_file, 0, 0) "you must have \"@ISA = qw(Exporter)\" to EXPORT something"
+    | Some pos ->
+	if not (exporting_something()) then warn_with_pos [Warn_import_export] pos "Inheritating from Exporter without EXPORTing anything");
+
+    let uses = List.rev (get_uses t) in
+    let required_packages = List.map (fun (s, (_, pos)) -> s, pos) uses in
+    let required_packages = List.fold_left (fold_tree (fun l -> 
+      function
+	| Perl_checker_comment(s, pos) when str_begins_with "require " s ->
+	    Some((skip_n_char 8 s, pos) :: l)
+	| Call(Deref(I_func, Ident (None, "require", pos)), [Ident _ as pkg]) ->
+	    let package = string_of_fromparser pkg in
+	    if uses_external_package package then None else Some((package, pos) :: l)
+	| Call(Deref(I_func, Ident (None, "require", pos)), [Raw_string(pkg, _)])
+	    when not (String.contains pkg '/') && Filename.check_suffix pkg ".pm" ->
+	    let package = Filename.chop_suffix pkg ".pm" in
+	    if uses_external_package package then None else Some((package, pos) :: l)
+	| _ -> None)
+      ) required_packages t in
+    { 
+      package_name = package_name;
+      has_package_name = current_package <> None ;
+      exports = exports ;
+      imported = ref None ;
+      vars_declared = Hashtbl.create 16 ;
+      uses = uses ;
+      required_packages = required_packages ;
+      body = t ;
+      isa = isa ;
+    }
+  ) current_packages in
+
+  let require_name = match require_name with
+  | Some require_name -> Some require_name
+  | None -> match packages with
+    | [ pkg ] when pkg.has_package_name -> Some pkg.package_name
+    | _ -> None
+  in
+  {
+   file_name = !Info.current_file ; 
+   require_name = require_name ;
+   lines_starts = !Info.current_file_lines_starts ;
+   build_time = build_time ;
+   packages = packages ;
+   from_basedir = from_basedir ;
+  }
+