blob: 79577ff4b9838169094cd8a885e15b6370716f37 (
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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* Objective Caml 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. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* 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. ***)
(* 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 explicitely *)
let exec_with_runtime =
generic_exec
(function () ->
match Sys.os_type with
"Win32" ->
(* This fould 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 "set CAML_DEBUG_SOCKET=%s && %s %s %s"
!socket_name
runtime_program
!program_name
!arguments
| _ ->
Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s"
!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 "set CAML_DEBUG_SOCKET=%s && %s %s"
!socket_name
!program_name
!arguments
| _ ->
Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s"
!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
|
