package / ocaml-base-compiler.4.10.0 / debugger / program_loading.ml
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
6 (* OCaml port by John Malecki and Xavier Leroy *)
7 (* *)
8 (* Copyright 1996 Institut National de Recherche en Informatique et *)
9 (* en Automatique. *)
10 (* *)
11 (* All rights reserved. This file is distributed under the terms of *)
12 (* the GNU Lesser General Public License version 2.1, with the *)
13 (* special exception on linking described in the file LICENSE. *)
14 (* *)
15 (**************************************************************************)
16
17 (* Program loading *)
18
19 open Unix
20 open Debugger_config
21 open Parameters
22 open Input_handling
23
24 (*** Debugging. ***)
25
26 let debug_loading = ref false
27
28 (*** Load a program. ***)
29
30 (* Function used for launching the program. *)
31 let launching_func = ref (function () -> ())
32
33 let load_program () =
34 !launching_func ();
35 main_loop ()
36
37 (*** Launching functions. ***)
38
39 (* Returns a command line prefix to set environment for the debuggee *)
40 let get_unix_environment () =
41 let f (vname, vvalue) =
42 Printf.sprintf "%s=%s " vname (Filename.quote vvalue)
43 in
44 String.concat "" (List.map f !Debugger_config.environment)
45 ;;
46
47 (* Notes:
48 1. This quoting is not the same as [Filename.quote] because the "set"
49 command is a shell built-in and its quoting rules are different
50 from regular commands.
51 2. Microsoft's documentation omits the double-quote from the list
52 of characters that need quoting, but that is a mistake (unquoted
53 quotes are included in the value, but they alter the quoting of
54 characters between them).
55 Reference: http://msdn.microsoft.com/en-us/library/bb490954.aspx
56 *)
57 let quote_for_windows_shell s =
58 let b = Buffer.create (20 + String.length s) in
59 for i = 0 to String.length s - 1 do
60 begin match s.[i] with
61 | '<' | '>' | '|' | '&' | '^' | '\"' ->
62 Buffer.add_char b '^';
63 | _ -> ()
64 end;
65 Buffer.add_char b s.[i];
66 done;
67 Buffer.contents b
68 ;;
69
70 (* Returns a command line prefix to set environment for the debuggee *)
71 let get_win32_environment () =
72 (* Note: no space before the & or Windows will add it to the value *)
73 let f (vname, vvalue) =
74 Printf.sprintf "set %s=%s&" vname (quote_for_windows_shell vvalue)
75 in
76 String.concat "" (List.map f !Debugger_config.environment)
77
78 (* A generic function for launching the program *)
79 let generic_exec_unix cmdline = function () ->
80 if !debug_loading then
81 prerr_endline "Launching program...";
82 let child =
83 try
84 fork ()
85 with x ->
86 Unix_tools.report_error x;
87 raise Toplevel in
88 match child with
89 0 ->
90 begin try
91 match fork () with
92 0 -> (* Try to detach the process from the controlling terminal,
93 so that it does not receive SIGINT on ctrl-C. *)
94 begin try ignore(setsid()) with Invalid_argument _ -> () end;
95 execv shell [| shell; "-c"; cmdline() |]
96 | _ -> exit 0
97 with x ->
98 Unix_tools.report_error x;
99 exit 1
100 end
101 | _ ->
102 match wait () with
103 (_, WEXITED 0) -> ()
104 | _ -> raise Toplevel
105
106 let generic_exec_win cmdline = function () ->
107 if !debug_loading then
108 prerr_endline "Launching program...";
109 try ignore(create_process "cmd.exe" [| "/C"; cmdline() |] stdin stdout stderr)
110 with x ->
111 Unix_tools.report_error x;
112 raise Toplevel
113
114 let generic_exec =
115 match Sys.os_type with
116 "Win32" -> generic_exec_win
117 | _ -> generic_exec_unix
118
119 (* Execute the program by calling the runtime explicitly *)
120 let exec_with_runtime =
121 generic_exec
122 (function () ->
123 match Sys.os_type with
124 "Win32" ->
125 (* This would fail on a file name with spaces
126 but quoting is even worse because Unix.create_process
127 thinks each command line parameter is a file.
128 So no good solution so far *)
129 Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s %s"
130 (get_win32_environment ())
131 !socket_name
132 runtime_program
133 !program_name
134 !arguments
135 | _ ->
136 Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s %s"
137 (get_unix_environment ())
138 !socket_name
139 (Filename.quote runtime_program)
140 (Filename.quote !program_name)
141 !arguments)
142
143 (* Execute the program directly *)
144 let exec_direct =
145 generic_exec
146 (function () ->
147 match Sys.os_type with
148 "Win32" ->
149 (* See the comment above *)
150 Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s"
151 (get_win32_environment ())
152 !socket_name
153 !program_name
154 !arguments
155 | _ ->
156 Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s"
157 (get_unix_environment ())
158 !socket_name
159 (Filename.quote !program_name)
160 !arguments)
161
162 (* Ask the user. *)
163 let exec_manual =
164 function () ->
165 print_newline ();
166 print_string "Waiting for connection...";
167 print_string ("(the socket is " ^ !socket_name ^ ")");
168 print_newline ()
169
170 (*** Selection of the launching function. ***)
171
172 type launching_function = (unit -> unit)
173
174 let loading_modes =
175 ["direct", exec_direct;
176 "runtime", exec_with_runtime;
177 "manual", exec_manual]
178
179 let set_launching_function func =
180 launching_func := func
181
182 (* Initialization *)
183
184 let _ =
185 set_launching_function exec_direct
186
187 (*** Connection. ***)
188
189 let connection = ref Primitives.std_io
190 let connection_opened = ref false
191