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