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 188 189 190
|
(**************************************************************************)
(* *)
(* 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 GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* 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
|