summaryrefslogtreecommitdiff
path: root/otherlibs/labltk/browser/shell.ml
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/browser/shell.ml')
-rw-r--r--otherlibs/labltk/browser/shell.ml237
1 files changed, 237 insertions, 0 deletions
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
new file mode 100644
index 0000000000..5af22d1b45
--- /dev/null
+++ b/otherlibs/labltk/browser/shell.ml
@@ -0,0 +1,237 @@
+(* $Id$ *)
+
+open Tk
+open Jg_tk
+
+(* Nice history class. May reuse *)
+
+class ['a] history () = object
+ val mutable history = ([] : 'a list)
+ val mutable count = 0
+ method empty = history = []
+ method add s = count <- 0; history <- s :: history
+ method previous =
+ let s = List.nth pos:count history in
+ count <- (count + 1) mod List.length history;
+ s
+ method next =
+ let l = List.length history in
+ count <- (l + count - 1) mod l;
+ List.nth history pos:((l + count - 1) mod l)
+end
+
+(* The shell class. Now encapsulated *)
+
+let protect f x = try f x with _ -> ()
+
+class shell :textw :prog :args :env =
+ let (in2,out1) = Unix.pipe ()
+ and (in1,out2) = Unix.pipe ()
+ and (err1,err2) = Unix.pipe () in
+object (self)
+ val pid = Unix.create_process_env :prog :args :env in:in2 out:out2 err:err2
+ val out = Unix.out_channel_of_descr out1
+ val h = new history ()
+ val mutable alive = true
+ val mutable reading = false
+ method alive = alive
+ method kill =
+ if Winfo.exists textw then Text.configure textw state:`Disabled;
+ if alive then begin
+ alive <- false;
+ protect close_out out;
+ List.iter fun:(protect Unix.close) [in1; err1; in2; out2; err2];
+ try
+ Fileevent.remove_fileinput fd:in1;
+ Fileevent.remove_fileinput fd:err1;
+ Unix.kill :pid signal:Sys.sigkill;
+ Unix.waitpid flags:[] pid; ()
+ with _ -> ()
+ end
+ method interrupt =
+ if alive then try
+ reading <- false;
+ Unix.kill :pid signal:Sys.sigint
+ with Unix.Unix_error _ -> ()
+ method send s =
+ if alive then try
+ output_string s to:out;
+ flush out
+ with Sys_error _ -> ()
+ method private read :fd :len =
+ try
+ let buffer = String.create :len in
+ let len = Unix.read fd :buffer pos:0 :len in
+ self#insert (String.sub buffer pos:0 :len);
+ Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+ with Unix.Unix_error _ -> ()
+ method history (dir : [`next|`previous]) =
+ if not h#empty then begin
+ if reading then begin
+ Text.delete textw start:(`Mark"input",[`Char 1])
+ end:(`Mark"insert",[])
+ end else begin
+ reading <- true;
+ Text.mark_set textw mark:"input"
+ index:(`Mark"insert",[`Char(-1)])
+ end;
+ self#insert (if dir = `previous then h#previous else h#next)
+ end
+ method private lex ?:start{= `Mark"insert",[`Linestart]}
+ ?end:endx{= `Mark"insert",[`Lineend]} () =
+ Lexical.tag textw :start end:endx
+ method insert text =
+ let idx = Text.index textw
+ index:(`Mark"insert",[`Char(-1);`Linestart]) in
+ Text.insert textw :text index:(`Mark"insert",[]);
+ self#lex start:(idx,[`Linestart]) ();
+ Text.see textw index:(`Mark"insert",[])
+ method private keypress c =
+ if not reading & c > " " then begin
+ reading <- true;
+ Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+ end
+ method private keyrelease c = if c <> "" then self#lex ()
+ method private return =
+ if reading then reading <- false
+ else Text.mark_set textw mark:"input"
+ index:(`Mark"insert",[`Linestart;`Char 1]);
+ self#lex start:(`Mark"input",[`Linestart]) ();
+ let s =
+ (* input is one character before real input *)
+ Text.get textw start:(`Mark"input",[`Char 1])
+ end:(`Mark"insert",[]) in
+ h#add s;
+ self#send s;
+ self#send "\n"
+ method private paste ev =
+ if not reading then begin
+ reading <- true;
+ Text.mark_set textw mark:"input"
+ index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)])
+ end
+ initializer
+ Lexical.init_tags textw;
+ let rec bindings =
+ [ ([[],`KeyPress],[`Char],fun ev -> self#keypress ev.ev_Char);
+ ([[],`KeyRelease],[`Char],fun ev -> self#keyrelease ev.ev_Char);
+ ([[],`KeyPressDetail"Return"],[],fun _ -> self#return);
+ ([[],`ButtonPressDetail 2], [`MouseX; `MouseY], self#paste);
+ ([[`Alt],`KeyPressDetail"p"],[],fun _ -> self#history `previous);
+ ([[`Alt],`KeyPressDetail"n"],[],fun _ -> self#history `next);
+ ([[`Meta],`KeyPressDetail"p"],[],fun _ -> self#history `previous);
+ ([[`Meta],`KeyPressDetail"n"],[],fun _ -> self#history `next);
+ ([[`Control],`KeyPressDetail"c"],[],fun _ -> self#interrupt);
+ ([[],`Destroy],[],fun _ -> self#kill) ]
+ in
+ List.iter bindings
+ fun:(fun (events,fields,f) ->
+ bind textw :events action:(`Set(fields,f)));
+ begin try
+ List.iter [in1;err1] fun:
+ begin fun fd ->
+ Fileevent.add_fileinput :fd
+ callback:(fun () -> self#read :fd len:1024)
+ end
+ with _ -> ()
+ end
+end
+
+(* Specific use of shell, for LablBrowser *)
+
+let shells : (string * shell) list ref = ref []
+
+(* Called before exiting *)
+let kill_all () =
+ List.iter !shells fun:(fun (_,sh) -> if sh#alive then sh#kill);
+ shells := []
+
+let get_all () =
+ let all = List.filter !shells pred:(fun (_,sh) -> sh#alive) in
+ shells := all;
+ all
+
+let may_exec prog =
+ try
+ let stats = Unix.stat prog in
+ stats.Unix.st_perm land 1 <> 0 or
+ stats.Unix.st_perm land 8 <> 0
+ & List.mem elt:stats.Unix.st_gid (Array.to_list (Unix.getgroups ())) or
+ stats.Unix.st_perm land 64 <> 0 & stats.Unix.st_uid = Unix.getuid ()
+ with Unix.Unix_error _ -> false
+
+let f :prog :title =
+ let progargs =
+ List.filter pred:((<>) "") (Str.split sep:(Str.regexp " ") prog) in
+ if progargs = [] then () else
+ let prog = List.hd progargs in
+ let path = try Sys.getenv "PATH" with Not_found -> "/bin:/usr/bin" in
+ let exec_path = Str.split sep:(Str.regexp":") path in
+ let exists =
+ if not (Filename.is_implicit prog) then may_exec prog else
+ List.exists exec_path
+ pred:(fun dir -> may_exec (Filename.concat dir prog)) in
+ if not exists then () else
+ let tl = Jg_toplevel.titled title in
+ let menus = Frame.create parent:tl name:"menubar" () in
+ let file_menu = new Jg_menu.c "File" parent:menus
+ and history_menu = new Jg_menu.c "History" parent:menus
+ and signal_menu = new Jg_menu.c "Signal" parent:menus in
+ pack [menus] side:`Top fill:`X;
+ pack [file_menu#button; history_menu#button; signal_menu#button]
+ side:`Left ipadx:(`Pix 5) anchor:`W;
+ let frame, tw, sb = Jg_text.create_with_scrollbar parent:tl in
+ Text.configure tw background:`White;
+ pack [sb] fill:`Y side:`Right;
+ pack [tw] fill:`Both expand:true side:`Left;
+ pack [frame] fill:`Both expand:true;
+ let reg = Str.regexp "TERM=" in
+ let env = Array.map (Unix.environment ()) fun:
+ begin fun s ->
+ if Str.string_match reg s pos:0 then "TERM=dumb" else s
+ end in
+ let load_path =
+ List2.flat_map !Config.load_path fun:(fun dir -> ["-I"; dir]) in
+ let args = Array.of_list (progargs @ load_path) in
+ let sh = new shell textw:tw :prog :env :args in
+ let current_dir = ref (Unix.getcwd ()) in
+ file_menu#add_command "Use..." command:
+ begin fun () ->
+ Fileselect.f title:"Use File" filter:"*.ml" sync:true dir:!current_dir ()
+ action:(fun l ->
+ if l = [] then () else
+ let name = List.hd l in
+ current_dir := Filename.dirname name;
+ if Filename.check_suffix name suff:".ml"
+ then
+ let cmd = "#use \"" ^ name ^ "\";;\n" in
+ sh#insert cmd; sh#send cmd)
+ end;
+ file_menu#add_command "Load..." command:
+ begin fun () ->
+ Fileselect.f title:"Load File" filter:"*.cm[oa]" sync:true ()
+ dir:!current_dir
+ action:(fun l ->
+ if l = [] then () else
+ let name = List.hd l in
+ current_dir := Filename.dirname name;
+ if Filename.check_suffix name suff:".cmo" or
+ Filename.check_suffix name suff:".cma"
+ then
+ let cmd = "#load \"" ^ name ^ "\";;\n" in
+ sh#insert cmd; sh#send cmd)
+ end;
+ file_menu#add_command "Import path" command:
+ begin fun () ->
+ List.iter (List.rev !Config.load_path)
+ fun:(fun dir -> sh#send ("#directory \"" ^ dir ^ "\";;\n"))
+ end;
+ file_menu#add_command "Close" command:(fun () -> destroy tl);
+ history_menu#add_command "Previous " accelerator:"M-p"
+ command:(fun () -> sh#history `previous);
+ history_menu#add_command "Next" accelerator:"M-n"
+ command:(fun () -> sh#history `next);
+ signal_menu#add_command "Interrupt " accelerator:"C-c"
+ command:(fun () -> sh#interrupt);
+ signal_menu#add_command "Kill" command:(fun () -> sh#kill);
+ shells := (title, sh) :: !shells
View Lorry Controller Status