From d2a7f91461402231dbfeea05d42874c4c75ad2d3 Mon Sep 17 00:00:00 2001 From: malc Date: Sun, 16 Sep 2007 22:30:50 +0400 Subject: [PATCH] 0.90 --- build.bat | 1 + build.sh | 3 + cl.ml | 48 +++++++++++ dep.ml | 55 ++++++++++++ dep7.ml | 60 ++++++++++++++ drive.ml | 188 +++++++++++++++++++++++++++++++++++++++++ driver.ml | 64 ++++++++++++++ link.ml | 53 ++++++++++++ path.ml | 281 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ utils.ml | 104 +++++++++++++++++++++++ wine.ml | 30 +++++++ 11 files changed, 887 insertions(+) create mode 100644 build.bat create mode 100644 build.sh create mode 100644 cl.ml create mode 100644 dep.ml create mode 100644 dep7.ml create mode 100644 drive.ml create mode 100644 driver.ml create mode 100644 link.ml create mode 100644 path.ml create mode 100644 utils.ml create mode 100644 wine.ml diff --git a/build.bat b/build.bat new file mode 100644 index 0000000..d9e6091 --- /dev/null +++ b/build.bat @@ -0,0 +1 @@ +ocamlc -o imt.exe unix.cma str.cma wine.ml utils.ml drive.ml path.ml cl.ml dep.ml dep7.ml link.ml driver.ml diff --git a/build.sh b/build.sh new file mode 100644 index 0000000..efccd64 --- /dev/null +++ b/build.sh @@ -0,0 +1,3 @@ +src="wine.ml utils.ml drive.ml path.ml cl.ml dep.ml dep7.ml link.ml driver.ml" + +ocamlc -o imt unix.cma str.cma $src diff --git a/cl.ml b/cl.ml new file mode 100644 index 0000000..880dfb2 --- /dev/null +++ b/cl.ml @@ -0,0 +1,48 @@ +let debug = false +let src_file_re = Str.regexp "^\\(.*\\)([0-9]+) :" +let inc_file_re = Str.regexp "Cannot open include file: '\\(.*\\)'" + +let process_include_err s = + let rec loop pos = + let opt_pos2 = + try + Some (Str.search_forward inc_file_re s pos) + with Not_found -> + None + in + match opt_pos2 with + | Some pos2 -> + let b, e = Utils.safe_group_extents 1 in + let win_path = String.sub s b (e - b) in + prerr_string (String.sub s pos b); + Path.prerr true win_path; + prerr_string (String.sub s e (String.length s - e)); + loop e + | None -> + prerr_string (String.sub s pos (String.length s - pos)) + in + loop 0 + +let process_cl_output_line s = + (* prerr_endline s; *) + if Str.string_match src_file_re s 0 + then + let win_path = Utils.safe_group 1 s in + Path.prerr false win_path; + let gend = Utils.safe_group_end 1 in + process_include_err (String.sub s gend (String.length s - gend)); + prerr_newline () + else + begin + process_include_err s; + prerr_newline () + end + +let invoke argv arg_start = + let tool = Utils.tool_name "cl" in + let args = Utils.make_arg_string Path.check_and_modify_absolute argv arg_start in + let command = Wine.command tool ^ " /nologo " ^ args in + let ic = Unix.open_process_in command in + Utils.iter_crlf_chan ic process_cl_output_line; + let code = Utils.close_process_in ic in + code diff --git a/dep.ml b/dep.ml new file mode 100644 index 0000000..d6ce282 --- /dev/null +++ b/dep.ml @@ -0,0 +1,55 @@ +let debug = false + +let line_re = Str.regexp "^#line [0-9]+ \"\\(.*\\)\"$" +let over_re = Str.regexp + "^cl : Command line warning D4025 : overriding '/W[^']+' with '/w'" + +let process_cl_cpp_output_line s set = + if Str.string_match line_re s 0 + then + let win_path = Utils.safe_group 1 s in + if debug && (not (Utils.StringSet.mem win_path set)) + then + prerr_endline s; + Utils.StringSet.add win_path set + else + set + +let invoke target argv arg_start = + let args = Utils.make_arg_string Path.check_and_modify_absolute argv arg_start in + let tool = Utils.tool_name "cl" in + let command = Wine.command tool ^ "/E /nologo " ^ args ^ " /w" in + let env = Unix.environment () in + let (ic, _, ec) as channels = Unix.open_process_full command env in + let ifiles = + Utils.fold_crlf_chan ic process_cl_cpp_output_line Utils.StringSet.empty in + Utils.iter_crlf_chan ec + begin + fun s -> + if not (Str.string_match over_re s 0) + then + prerr_endline s + end; + let code = Utils.close_process_full channels in + if code = 0 + then + begin + print_string target; + print_string ": "; + Utils.StringSet.iter + begin + fun win_path -> + let unix_path = Path.find2 win_path in + match unix_path with + | None -> + prerr_string "Cannot convert windows path: '"; + prerr_string (String.escaped win_path); + prerr_endline "' to unix" + | Some unix_path -> + print_string unix_path; + print_char ' ' + end ifiles; + print_newline (); + end; + code + diff --git a/dep7.ml b/dep7.ml new file mode 100644 index 0000000..35a8e3c --- /dev/null +++ b/dep7.ml @@ -0,0 +1,60 @@ +let note_re = Str.regexp "^Note: including file: *\\(.*\\)$" + +let process_cl_dep7_output_line s set = + if Str.string_match note_re s 0 + then + let win_path = Utils.safe_group 1 s in + let unix_path = Path.find2 win_path in + match unix_path with + | Some path -> + Utils.StringSet.add path set + | None -> + prerr_string + "Dep7.process_cl_dep7_output_line: Cannot find unix path for "; + prerr_endline (String.escaped win_path); + set + else + begin + Cl.process_cl_output_line s; + set + end + +let test () = + let re = Str.regexp "/showIncludes" in + let tool = Utils.tool_name "cl" in + let command = Wine.command tool ^ " /?" in + let ic = Unix.open_process_in command in + let process s = + if Str.string_match re s 0 + then + exit 0 + else + () + in + Utils.iter_crlf_chan ic process; + exit 1 + +let invoke target argv arg_start = + let args = Utils.make_arg_string Path.check_and_modify_absolute argv arg_start in + let tool = Utils.tool_name "cl" in + let command = Wine.command tool ^ " /Zs /showIncludes /nologo " ^ args in + let ic = Unix.open_process_in command in + let ifiles = + Utils.fold_crlf_chan ic process_cl_dep7_output_line + Utils.StringSet.empty + in + let code = Utils.close_process_in ic in + if code = 0 + then + begin + print_string target; + print_string ": "; + Utils.StringSet.iter + begin + fun s -> + print_string s; + print_char ' ' + end ifiles; + print_newline (); + end; + code diff --git a/drive.ml b/drive.ml new file mode 100644 index 0000000..4f7ef53 --- /dev/null +++ b/drive.ml @@ -0,0 +1,188 @@ +let drive_tbl = Array.create (Char.code 'z' - Char.code 'a' + 1) None + +let root = + let rec loop i = + if i = Array.length drive_tbl + then + None + else + match drive_tbl.(i) with + | Some "" -> + Some (Char.chr (Char.code 'a' + i)) + | _ -> + loop (succ i) + in + lazy (loop 0) + +let get_root () = + Lazy.force_val root + +let subst s = + let slen = String.length s in + if slen >= 3 + then + if s.[1] = ':' + then + if s.[2] = '/' + then + let c = Char.lowercase s.[0] in +(* prerr_string "Drive "; *) +(* prerr_char c; *) +(* prerr_newline (); *) + let i = Char.code c - Char.code 'a' in + if i < Array.length drive_tbl + then + match drive_tbl.(i) with + | None -> + s + | Some d -> + let dlen = String.length d in + let r = String.create (slen - 2 + dlen) in + StringLabels.blit + ~src:d + ~src_pos:0 + ~dst:r + ~dst_pos:0 + ~len:dlen; + StringLabels.blit + ~src:s + ~src_pos:2 + ~dst:r + ~dst_pos:dlen + ~len:(slen - 2); + r + else + begin + prerr_string "Drive.subst bogus drive "; + prerr_endline (String.escaped s); + s + end + else + begin + prerr_string "Drive.subst no slash "; + prerr_endline (String.escaped s); + s + end + else + s + else + s + +let process_exn s = function + | Unix.Unix_error(code, fn_name, fn_arg) -> + prerr_string s; + prerr_string ": "; + prerr_string fn_name; + prerr_char '('; + if String.length fn_arg > 0 + then + prerr_string fn_arg; + prerr_string "): "; + prerr_endline (Unix.error_message code) + | exn -> + prerr_string s; + prerr_string ": "; + prerr_endline (Printexc.to_string exn) + +let process_dosdevices dir_path dir = + let get_path_drive win_path = + if String.length win_path = 2 + then + if win_path.[1] = ':' + then + let c = Char.lowercase win_path.[0] in + if (c >= 'a' && c <= 'z') + then + Some c + else + None + else + None + else + None + in + + let put_drive drive_letter unix_path = + let i = Char.code drive_letter - Char.code 'a' in + let l = String.length unix_path in + let drive_path = + if unix_path.[l - 1] = '/' + then + String.sub unix_path 0 (pred l) + else + unix_path + in + drive_tbl.(i) <- Some drive_path + in + + let rec loop () = + let opt_s = + try + let s = Unix.readdir dir in + Some s + with + | End_of_file -> + (* prerr_endline "Drive(readdir): empty directory"; *) + None + in + match opt_s with + | None -> + () + | Some s -> + begin + match get_path_drive s with + | Some c -> + let opt_target = + try + Some (Unix.readlink (Filename.concat dir_path s)) + with + | exn -> + process_exn + "Drive.process_dosdevices(loop:readlink)" + exn; + None + in + Utils.some_action (put_drive c) () opt_target + + | None -> + () + end; + loop () + in + try + loop () + with + | exn -> + process_exn "Drive.process_dosdevices(loop:?)" exn + +let init () = + if Wine.native + then + let _A = Char.code 'A' in + for i = 0 to pred (Array.length drive_tbl) do + let s = "_:" in + s.[0] <- Char.chr (i + _A); + drive_tbl.(i) <- Some s + done + else + let dir_path = Filename.concat Wine.root_path "dosdevices" in + let opt_dir = + try + Some (Unix.opendir dir_path) + with + | exn -> + process_exn "Drive.init" exn; + None + in + match opt_dir with + | None -> + prerr_endline "Can not establish drive mapping"; + | Some dir -> + process_dosdevices dir_path dir; + begin + try + Unix.closedir dir + with + | exn -> + process_exn "Drive.init" exn; + end diff --git a/driver.ml b/driver.ml new file mode 100644 index 0000000..13b4fe0 --- /dev/null +++ b/driver.ml @@ -0,0 +1,64 @@ +let main argv = + let show_usage () = + print_endline "Incredible Mega Thing Version 0.90"; + print_endline "Copryight (C) 2005 extremely cool hacker. All rights reserved."; + print_newline (); + print_string "usage: "; + print_string (Filename.basename Sys.executable_name); + print_endline " command [ command-argument ] [ arguments ... ]"; + List.iter print_endline + ["command is one of: "; + "\tcl : invoke cl.exe"; + "\tdep target : analyze cl.exe /E output, make dependencies"; + "\tdep7 target : analyze cl.exe /showIncludes output, make dependencies"; + "\tdep7-test : test weather dep7 is available"; + "\tlink : invoke link.exe"; + ""]; + print_endline "Have a nice day"; + exit 100 + in + + if Array.length argv < 2 + then + show_usage () + else + begin + Drive.init (); + let code = + match argv.(1) with + | "cl" -> + Cl.invoke argv 2 + + | "dep7" -> + if Array.length argv < 3 + then + show_usage () + else + let target = argv.(2) in + Dep7.invoke target argv 3 + + | "dep" -> + if Array.length argv < 3 + then + show_usage () + else + let target = argv.(2) in + Dep.invoke target argv 3 + + | "link" -> + Link.invoke argv 2 + + | "dep7-test" -> + Dep7.test () + + | cmd -> + prerr_string "invalid command: "; + prerr_string (String.escaped cmd); + prerr_newline (); + show_usage () + in + exit code + end + +let _ = + main Sys.argv diff --git a/link.ml b/link.ml new file mode 100644 index 0000000..9288a45 --- /dev/null +++ b/link.ml @@ -0,0 +1,53 @@ +let emit_endline = ref prerr_endline + +let process_link_output s = + if s <> "LINK : warning LNK4044: unrecognized option '/nologo'; ignored" + then + !emit_endline s + +let invoke argv arg_start = + let is_empty s = + let rec loop i = + if i = String.length s + then + true + else + if s.[i] = ' ' || s.[i] = '\t' + then + loop (succ i) + else + false + in + loop 0 + in + + let find_from pred arr pos = + let rec loop i = + if i >= Array.length arr + then + false + else + pred arr.(i) || loop (succ i) + in + loop pos + in + + let _ = + if find_from (fun s -> s = "/dump" || s = "-dump") argv arg_start + then + emit_endline := print_endline + in + + let args = Utils.make_arg_string Path.check_and_modify_absolute argv arg_start in + let tool = Utils.tool_name "link" in + let command = + if is_empty args + then + Wine.command tool + else + Wine.command tool ^ args ^ " /nologo" + in + let ic = Unix.open_process_in command in + Utils.iter_crlf_chan ic process_link_output; + let code = Utils.close_process_in ic in + code diff --git a/path.ml b/path.ml new file mode 100644 index 0000000..219cd1e --- /dev/null +++ b/path.ml @@ -0,0 +1,281 @@ +let debug = false + +type unix_path = + | Bad_dir + | Bad_file + | Path of string + +let convert_compress_slashes s = + let l = String.length s in + let t = String.create l in + let rec loop prev_slash i j = + if i = l + then + j + else + let c = s.[i] in + if c = '\\' + then + if prev_slash + then + loop true (succ i) j + else + begin + t.[j] <- '/'; + loop true (succ i) (succ j) + end + else + begin + t.[j] <- c; + loop false (succ i) (succ j) + end + in + let rl = loop false 0 0 in + if rl = String.length t + then + t + else + String.sub t 0 rl + +let convert_slashes = convert_compress_slashes + +let find_unix_path path = + let dirname = Filename.dirname path in + if debug + then + Format.eprintf "find_unix_path: %S - %S %b@.@." + path dirname (Sys.file_exists dirname); + if not (Sys.file_exists dirname) + then + Bad_dir + else + if not (Sys.file_exists path) + then + let basename = Filename.basename path in + let names = Sys.readdir dirname in + if debug + then + Format.eprintf "readdir: %S@." dirname; + let lowercase_name = String.lowercase basename in + let find_string_lower target names = + let len = Array.length names in + let rec finder index = + if index = len + then + None + else + let name = names.(index) in + let lowercase_name = String.lowercase name in + if lowercase_name = target + then + Some name + else + finder (succ index) + in + finder 0 + in + match (find_string_lower lowercase_name names) with + | None -> + Bad_file + | Some name -> + Path (Filename.concat dirname name) + else + Path path + +let rec find path = + if debug + then + Format.eprintf "find(%S)@." path; + let res = find_unix_path path in + match res with + | Bad_dir -> + let dirname = Filename.dirname path in + let res = find dirname in + begin + match res with + | Path correct_dirname -> + let basename = Filename.basename path in + let path = Filename.concat correct_dirname basename in + find_unix_path path + | _ -> + Bad_dir + end + | other -> + other + +let split s = + let len = String.length s in + let rec collect list pos = + if pos = len + then + list + else + match s.[pos] with + | ' ' | '\t' | '\n' | '\r' -> + collect list (succ pos) + | '"' -> + let endpos = + try + String.index_from s pos '"' + with Not_found-> + prerr_string "Path.split: mismatched quote "; + prerr_string (String.escaped s); + prerr_string " pos:"; + prerr_int pos; + prerr_newline (); + len + in + let s = String.sub s pos (endpos - pos) in + collect (s :: list) endpos + | _ -> + let endpos = + try + String.index_from s pos ' ' + with Not_found-> + len + in + let s = String.sub s pos (endpos - pos) in + collect (s :: list) endpos + in + collect [] 0 + +let find2 win_path = + let s1 = + if not Wine.native || !Wine.native_convert_slashes + then + convert_slashes win_path + else + win_path + in + if Wine.native + then + Some s1 + else + let s2 = Drive.subst s1 in + let unix_path = find s2 in + begin + match unix_path with + | Bad_dir + | Bad_file -> + if debug + then + begin + prerr_string "Path.find2 Bad_file: "; + prerr_string (String.copy win_path); + prerr_char ' '; + prerr_string (String.copy s1); + prerr_char ' '; + prerr_string (String.copy s2); + prerr_char ' '; + prerr_newline (); + exit 103 + end; + None + | Path unix_path -> + Some unix_path + end + +let output oc dir_only win_path = + let s1 = + if not Wine.native || !Wine.native_convert_slashes + then + convert_slashes win_path + else + win_path + in + if Wine.native + then + output_string oc s1 + else + let s2 = Drive.subst s1 in + let s3 = + if dir_only + then + Filename.dirname s2 + else + s2 + in + let unix_path = find s3 in + begin + match unix_path with + | Bad_dir + | Bad_file -> + if debug + then + begin + prerr_string "Path.output Bad_file: "; + prerr_string ( win_path); + print_char ' '; + prerr_string ( s1); + prerr_char ' '; + prerr_string ( s2); + prerr_char ' '; + prerr_newline (); + exit 104 + end; + output_string oc win_path + | Path unix_path -> + if dir_only + then + output_string oc (Filename.concat s3 (Filename.basename s2)) + else + output_string oc unix_path + end + +let prerr = output stderr +let print = output stdout + +let abs_predicate s = + not (Filename.is_relative s) && Sys.file_exists s + +let check_and_modify_absolute_no_root s = + if abs_predicate s + then + begin + prerr_string (String.escaped s); + prerr_endline + " is absolute and exists, but no wine drive mapping root is defined"; + s + end + else + s + +let check_and_modify_absolute_root root s = + if abs_predicate s + then + if false + then + let r = String.create (String.length s + 2) in + r.[0] <- root; + r.[1] <- ':'; + StringLabels.blit + ~src:s + ~src_pos:0 + ~dst:r + ~dst_pos:2 + ~len:(String.length s); + r + else + let r = String.create (String.length s + 1) in + r.[0] <- '\\'; + r.[1] <- '\\'; + StringLabels.blit + ~src:s + ~src_pos:1 + ~dst:r + ~dst_pos:2 + ~len:(String.length s - 1); + r + else + s + +let check_and_modify_absolute s = + if Wine.native + then + s + else + match Drive.get_root () with + | None -> + check_and_modify_absolute_no_root s + | Some root -> + check_and_modify_absolute_root root s diff --git a/utils.ml b/utils.ml new file mode 100644 index 0000000..b930c79 --- /dev/null +++ b/utils.ml @@ -0,0 +1,104 @@ +module StringSet = Set.Make (struct type t = string let compare = compare end) + +let decrlf line = + if line.[String.length line - 1] = '\r' + then + String.sub line 0 (String.length line - 1) + else + line + +let safe_input_line ic = + try + Some (input_line ic) + with + | End_of_file -> + None + +let iter_crlf_chan ic f = + let rec loop () = + let opt_line = safe_input_line ic in + match opt_line with + | Some line -> + f (decrlf line); + loop () + | None -> + () + in + loop () + +let fold_crlf_chan ic f init = + let rec loop accu = + let opt_line = safe_input_line ic in + match opt_line with + | Some line -> + let accu = f (decrlf line) accu in + loop accu + | None -> + accu + in + loop init + +let process_status = function + | Unix.WEXITED code -> + code + | Unix.WSIGNALED signum -> + prerr_string "signalled "; + prerr_int signum; + prerr_newline (); + 101 + | Unix.WSTOPPED signum -> + prerr_string "stopped "; + prerr_int signum; + prerr_newline (); + 102 + +let close_process_in ic = + let status = Unix.close_process_in ic in + process_status status + +let close_process_full channels = + let status = Unix.close_process_full channels in + process_status status + +let make_arg_string f argv pos = + let rec loop accu i = + if i >= Array.length argv + then + List.rev accu + else + let s = f argv.(i) in + let accu = s :: accu in + loop accu (succ i) + in + let arg_list = loop [] pos in + String.concat " " arg_list + +let safe_group_extents group_nr = + try + Str.group_beginning group_nr, Str.group_end group_nr + with Not_found -> + failwith "Internal error (cannot get group extents)" + +let safe_group group_nr s = + try + Str.matched_group group_nr s + with Not_found -> + failwith "Internal error (cannot find matched group)" + +let safe_group_end group_nr = + try + Str.group_end group_nr + with Not_found -> + failwith "Internal error (cannot find group end)" + +let some_action f d = function + | None -> + d + | Some v -> + f v + +let tool_name s = + try + Unix.getenv ("IMT_" ^ (String.uppercase s)) + with Not_found -> + s diff --git a/wine.ml b/wine.ml new file mode 100644 index 0000000..45fb2a9 --- /dev/null +++ b/wine.ml @@ -0,0 +1,30 @@ +let native_convert_slashes = ref false + +let native = Sys.os_type = "Win32" + +let wine_command s = "wine " ^ s +let native_command s = s + +let command = + if Sys.os_type = "win32" + then + wine_command + else + native_command + +let root_path = + if Sys.os_type = "win32" + then + "/" + else + try + Sys.getenv "WINE_PREFIX" + with + | Not_found -> + begin + try + Filename.concat (Sys.getenv "HOME") ".wine" + with + | Not_found -> + failwith "Can not find wine's root path" + end -- 2.11.4.GIT