l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/browser/shell.ml

   1 (*************************************************************************)
   2 (*                                                                       *)
   3 (*                Objective Caml LablTk library                          *)
   4 (*                                                                       *)
   5 (*            Jacques Garrigue, Kyoto University RIMS                    *)
   6 (*                                                                       *)
   7 (*   Copyright 1999 Institut National de Recherche en Informatique et    *)
   8 (*   en Automatique and Kyoto University.  All rights reserved.          *)
   9 (*   This file is distributed under the terms of the GNU Library         *)
  10 (*   General Public License, with the special exception on linking       *)
  11 (*   described in file ../../../LICENSE.                                 *)
  12 (*                                                                       *)
  13 (*************************************************************************)
  14
  15 (* $Id: shell.ml 7327 2006-01-18 13:26:03Z garrigue $ *)
  16
  17 open StdLabels
  18 module Unix = UnixLabels
  19 open Tk
  20 open Jg_tk
  21 open Dummy
  22
  23 (* Here again, memoize regexps *)
  24
  25 let (~!) = Jg_memo.fast ~f:Str.regexp
  26
  27 (* Nice history class. May reuse *)
  28
  29 class ['a] history () = object
  30   val mutable history = ([] : 'a list)
  31   val mutable count = 0
  32   method empty = history = []
  33   method add s = count <- 0; history <- s :: history
  34   method previous =
  35     let s = List.nth history count in
  36     count <- (count + 1) mod List.length history;
  37     s
  38   method next =
  39     let l = List.length history in
  40     count <- (l + count - 1) mod l;
  41     List.nth history ((l + count - 1) mod l)
  42 end
  43
  44 let dump_handle (h : Unix.file_descr) =
  45   let obj = Obj.repr h in
  46   if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then
  47     invalid_arg "Shell.dump_handle";
  48   Nativeint.format "%x" (Obj.obj obj)
  49
  50 (* The shell class. Now encapsulated *)
  51
  52 let protect f x = try f x with _ -> ()
  53
  54 let is_win32 = Sys.os_type = "Win32"
  55 let use_threads = is_win32
  56 let use_sigpipe = is_win32
  57
  58 class shell ~textw ~prog ~args ~env ~history =
  59   let (in2,out1) = Unix.pipe ()
  60   and (in1,out2) = Unix.pipe ()
  61   and (err1,err2) = Unix.pipe ()
  62   and (sig2,sig1) = Unix.pipe () in
  63 object (self)
  64   val pid =
  65     let env =
  66       if use_sigpipe then
  67         let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in
  68         Array.append env [|sigdef|]
  69       else env
  70     in
  71     Unix.create_process_env ~prog ~args ~env
  72       ~stdin:in2 ~stdout:out2 ~stderr:err2
  73   val out = Unix.out_channel_of_descr out1
  74   val h : _ history = history
  75   val mutable alive = true
  76   val mutable reading = false
  77   val ibuffer = Buffer.create 1024
  78   val imutex = Mutex.create ()
  79   val mutable ithreads = []
  80   method alive = alive
  81   method kill =
  82     if Winfo.exists textw then Text.configure textw ~state:`Disabled;
  83     if alive then begin
  84       alive <- false;
  85       protect close_out out;
  86       try
  87         if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1);
  88         List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2];
  89         if not use_threads then begin
  90           Fileevent.remove_fileinput ~fd:in1;
  91           Fileevent.remove_fileinput ~fd:err1;
  92         end;
  93         if not use_sigpipe then begin
  94           Unix.kill ~pid ~signal:Sys.sigkill;
  95           ignore (Unix.waitpid ~mode:[] pid)
  96         end
  97       with _ -> ()
  98     end
  99   method interrupt =
 100     if alive then try
 101       reading <- false;
 102       if use_sigpipe then begin
 103         ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1);
 104         self#send " "
 105       end else
 106         Unix.kill ~pid ~signal:Sys.sigint
 107     with Unix.Unix_error _ -> ()
 108   method send s =
 109     if alive then try
 110       output_string out s;
 111       flush out
 112     with Sys_error _ -> ()
 113   method private read ~fd ~len =
 114     begin try
 115       let buf = String.create len in
 116       let len = Unix.read fd ~buf ~pos:0 ~len in
 117       if len > 0 then begin
 118         self#insert (String.sub buf ~pos:0 ~len);
 119         Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
 120       end;
 121       len
 122     with Unix.Unix_error _ -> 0
 123     end;
 124   method history (dir : [`Next|`Previous]) =
 125     if not h#empty then begin
 126       if reading then begin
 127         Text.delete textw ~start:(`Mark"input",[`Char 1])
 128           ~stop:(`Mark"insert",[])
 129       end else begin
 130         reading <- true;
 131         Text.mark_set textw ~mark:"input"
 132           ~index:(`Mark"insert",[`Char(-1)])
 133       end;
 134       self#insert (if dir = `Previous then h#previous else h#next)
 135     end
 136   method private lex ?(start = `Mark"insert",[`Linestart])
 137       ?(stop = `Mark"insert",[`Lineend]) () =
 138     Lexical.tag textw ~start ~stop
 139   method insert text =
 140     let idx = Text.index textw
 141         ~index:(`Mark"insert",[`Char(-1);`Linestart]) in
 142     Text.insert textw ~text ~index:(`Mark"insert",[]);
 143     self#lex ~start:(idx,[`Linestart]) ();
 144     Text.see textw ~index:(`Mark"insert",[])
 145   method private keypress c =
 146     if not reading && c > " " then begin
 147       reading <- true;
 148       Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
 149     end
 150   method private keyrelease c = if c <> "" then self#lex ()
 151   method private return =
 152     if reading then reading <- false
 153     else Text.mark_set textw ~mark:"input"
 154         ~index:(`Mark"insert",[`Linestart;`Char 1]);
 155     Text.mark_set textw ~mark:"insert" ~index:(`Mark"insert",[`Lineend]);
 156     self#lex ~start:(`Mark"input",[`Linestart]) ();
 157     let s =
 158       (* input is one character before real input *)
 159       Text.get textw ~start:(`Mark"input",[`Char 1])
 160         ~stop:(`Mark"insert",[]) in
 161     h#add s;
 162     Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n";
 163     Text.yview_index textw ~index:(`Mark"insert",[]);
 164     self#send s;
 165     self#send "\n"
 166   method private paste ev =
 167     if not reading then begin
 168       reading <- true;
 169       Text.mark_set textw ~mark:"input"
 170         ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)])
 171     end
 172   initializer
 173     Lexical.init_tags textw;
 174     let rec bindings =
 175       [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char);
 176         ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char);
 177         (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *)
 178         ([], `ButtonPressDetail 2, [`MouseX; `MouseY],  self#paste);
 179         ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
 180         ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next);
 181         ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous);
 182         ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next);
 183         ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt);
 184         ([], `Destroy, [], fun _ -> self#kill) ]
 185     in
 186     List.iter bindings ~f:
 187       begin fun (modif,event,fields,action) ->
 188         bind textw ~events:[`Modified(modif,event)] ~fields ~action
 189       end;
 190     bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true
 191       ~action:(fun _ -> self#return; break());
 192     List.iter ~f:Unix.close [in2;out2;err2];
 193     if use_threads then begin
 194       let fileinput_thread fd =
 195         let buf = String.create 1024 in
 196         let len = ref 0 in
 197         try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do
 198           Mutex.lock imutex;
 199           Buffer.add_substring ibuffer buf 0 !len;
 200           Mutex.unlock imutex
 201         done with Unix.Unix_error _ -> ()
 202       in
 203       ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread);
 204       let rec read_buffer () =
 205         Mutex.lock imutex;
 206         if Buffer.length ibuffer > 0 then begin
 207           self#insert (Str.global_replace ~!"\r\n" "\n"
 208                          (Buffer.contents ibuffer));
 209           Buffer.reset ibuffer;
 210           Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)])
 211         end;
 212         Mutex.unlock imutex;
 213         Timer.set ~ms:100 ~callback:read_buffer
 214       in
 215       read_buffer ()
 216     end else begin
 217       try
 218         List.iter [in1;err1] ~f:
 219           begin fun fd ->
 220             Fileevent.add_fileinput ~fd
 221               ~callback:(fun () -> ignore (self#read ~fd ~len:1024))
 222           end
 223       with _ -> ()
 224     end
 225 end
 226
 227 (* Specific use of shell, for OCamlBrowser *)
 228
 229 let shells : (string * shell) list ref = ref []
 230
 231 (* Called before exiting *)
 232 let kill_all () =
 233   List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill);
 234   shells := []
 235
 236 let get_all () =
 237   let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in
 238   shells := all;
 239   all
 240
 241 let may_exec_unix prog =
 242   try Unix.access prog ~perm:[Unix.X_OK]; prog
 243   with Unix.Unix_error _ -> ""
 244
 245 let may_exec_win prog =
 246   let has_ext =
 247     List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in
 248   if has_ext then may_exec_unix prog else
 249   List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:""
 250     ~f:(fun res prog -> if res = "" then may_exec_unix prog else res)
 251
 252 let may_exec =
 253   if is_win32 then may_exec_win else may_exec_unix
 254
 255 let path_sep = if is_win32 then ";" else ":"
 256
 257 let warnings = ref "Al"
 258
 259 let program_not_found prog =
 260   Jg_message.info ~title:"Error"
 261     ("Program \"" ^ prog ^ "\"\nwas not found in path")
 262
 263 let protect_arg s =
 264   if String.contains s ' ' then "\"" ^ s ^ "\"" else s
 265
 266 let f ~prog ~title =
 267   let progargs =
 268     List.filter ~f:((<>) "") (Str.split ~!" " prog) in
 269   if progargs = [] then () else
 270   let prog = List.hd progargs in
 271   let path =
 272     try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
 273   let exec_path = Str.split ~!path_sep path in
 274   let exec_path = if is_win32 then "."::exec_path else exec_path in
 275   let progpath =
 276     if not (Filename.is_implicit prog) then may_exec prog else
 277     List.fold_left exec_path ~init:"" ~f:
 278       (fun res dir ->
 279         if res = "" then may_exec (Filename.concat dir prog) else res) in
 280   if progpath = "" then program_not_found prog else
 281   let tl = Jg_toplevel.titled title in
 282   let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in
 283   Toplevel.configure tl ~menu:menus;
 284   let file_menu = new Jg_menu.c "File" ~parent:menus
 285   and history_menu = new Jg_menu.c "History" ~parent:menus
 286   and signal_menu = new Jg_menu.c "Signal" ~parent:menus in
 287   let frame, tw, sb = Jg_text.create_with_scrollbar tl in
 288   Text.configure tw ~background:`White;
 289   pack [sb] ~fill:`Y ~side:`Right;
 290   pack [tw] ~fill:`Both ~expand:true ~side:`Left;
 291   pack [frame] ~fill:`Both ~expand:true;
 292   let env = Array.map (Unix.environment ()) ~f:
 293       begin fun s ->
 294         if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s
 295       end in
 296   let load_path =
 297     List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in
 298   let load_path =
 299     if is_win32 then List.map ~f:protect_arg load_path else load_path in
 300   let labels = if !Clflags.classic then ["-nolabels"] else [] in
 301   let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in
 302   let warnings =
 303     if List.mem "-w" progargs || !warnings = "Al" then []
 304     else ["-w"; !warnings]
 305   in
 306   let args =
 307     Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in
 308   let history = new history () in
 309   let start_shell () =
 310     let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in
 311     shells := (title, sh) :: !shells;
 312     sh
 313   in
 314   let sh = ref (start_shell ()) in
 315   let current_dir = ref (Unix.getcwd ()) in
 316   file_menu#add_command "Restart" ~command:
 317     begin fun () ->
 318       (!sh)#kill;
 319       Text.configure tw ~state:`Normal;
 320       Text.insert tw ~index:(`End,[]) ~text:"\n";
 321       Text.see tw ~index:(`End,[]);
 322       Text.mark_set tw ~mark:"insert" ~index:(`End,[]);
 323       sh := start_shell ();
 324     end;
 325   file_menu#add_command "Use..." ~command:
 326     begin fun () ->
 327       Fileselect.f ~title:"Use File" ~filter:"*.ml"
 328         ~sync:true ~dir:!current_dir ()
 329         ~action:(fun l ->
 330           if l = [] then () else
 331           let name = Fileselect.caml_dir (List.hd l) in
 332           current_dir := Filename.dirname name;
 333           if Filename.check_suffix name ".ml"
 334           then
 335             let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in
 336             (!sh)#insert cmd; (!sh)#send cmd)
 337     end;
 338   file_menu#add_command "Load..." ~command:
 339     begin fun () ->
 340       Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true ()
 341         ~dir:!current_dir
 342         ~action:(fun l ->
 343           if l = [] then () else
 344           let name = Fileselect.caml_dir (List.hd l) in
 345           current_dir := Filename.dirname name;
 346           if Filename.check_suffix name ".cmo" ||
 347             Filename.check_suffix name ".cma"
 348           then
 349             let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in
 350             (!sh)#insert cmd; (!sh)#send cmd)
 351     end;
 352   file_menu#add_command "Import path" ~command:
 353     begin fun () ->
 354       List.iter (List.rev !Config.load_path) ~f:
 355         (fun dir ->
 356           (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n"))
 357     end;
 358   file_menu#add_command "Close" ~command:(fun () -> destroy tl);
 359   history_menu#add_command "Previous  " ~accelerator:"M-p"
 360     ~command:(fun () -> (!sh)#history `Previous);
 361   history_menu#add_command "Next" ~accelerator:"M-n"
 362     ~command:(fun () -> (!sh)#history `Next);
 363   signal_menu#add_command "Interrupt  " ~accelerator:"C-c"
 364     ~command:(fun () -> (!sh)#interrupt);
 365   signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill)