6 (* Nice history class. May reuse *)
8 class ['a] history () = object
9 val mutable history = ([] : 'a list)
11 method empty = history = []
12 method add s = count <- 0; history <- s :: history
14 let s = List.nth history count in
15 count <- (count + 1) mod List.length history;
18 let l = List.length history in
19 count <- (l + count - 1) mod l;
20 List.nth history ((l + count - 1) mod l)
23 (* The shell class. Now encapsulated *)
25 let protect f x = try f x with _ -> ()
27 class shell ~prog ~args ~env ?packing ?show () =
28 let (in2,out1) = Unix.pipe ()
29 and (in1,out2) = Unix.pipe ()
30 and (err1,err2) = Unix.pipe () in
31 let _ = List.iter ~f:Unix.set_nonblock [out1;in1;err1] in
33 val textw = GEdit.text ~editable:true ?packing ?show ()
34 val pid = Unix.create_process_env
35 ~prog ~args ~env ~stdin:in2 ~stdout:out2 ~stderr:err2
36 val out = Unix.out_channel_of_descr out1
37 val h = new history ()
38 val mutable alive = true
39 val mutable reading = false
40 val mutable input_start = 0
44 textw#set_editable false;
47 protect close_out out;
48 List.iter ~f:(protect Unix.close) [in1; err1; in2; out2; err2];
50 Unix.kill ~pid ~signal:Sys.sigkill;
51 Unix.waitpid pid ~mode:[]; ()
57 Unix.kill ~pid ~signal:Sys.sigint
58 with Unix.Unix_error _ -> ()
63 with Sys_error _ -> ()
64 method private read ~fd ~len =
66 let buf = String.create len in
67 let len = Unix.read fd ~buf ~pos:0 ~len in
69 textw#set_position textw#length;
70 self#insert (String.sub buf ~pos:0 ~len);
71 input_start <- textw#position;
74 with Unix.Unix_error _ -> 0
75 method history (dir : [`next|`previous]) =
76 if not h#empty then begin
78 textw#delete_text ~start:input_start ~stop:textw#position;
81 input_start <- textw#position
83 self#insert (if dir = `previous then h#previous else h#next);
85 val mutable lexing = false
86 method private lex ~start ~stop:e =
87 if not lexing && start < e then begin
89 Lexical.tag textw ~start ~stop:e;
92 method insert ?(lex=true) text =
93 let start = Text.line_start textw in
95 if lex then self#lex ~start ~stop:(Text.line_end textw)
96 method private keypress c =
97 if not reading & c > " " then begin
99 input_start <- textw#position
101 method private return () =
102 if reading then reading <- false
103 else input_start <- textw#position;
104 textw#set_position (Text.line_end textw);
105 let s = textw#get_chars ~start:input_start ~stop:textw#position in
109 method private paste () =
110 if not reading then begin
112 input_start <- textw#position;
115 textw#event#connect#key_press ~callback:
117 if GdkEvent.Key.keyval ev = _Return && GdkEvent.Key.state ev = []
119 else self#keypress (GdkEvent.Key.string ev);
122 textw#connect#after#insert_text ~callback:
125 self#lex ~start:(Text.line_start textw ~pos:(pos - String.length s))
126 ~stop:(Text.line_end textw ~pos)
128 textw#connect#after#delete_text ~callback:
129 begin fun ~start:pos ~stop ->
131 self#lex ~start:(Text.line_start textw ~pos)
132 ~stop:(Text.line_end textw ~pos)
134 textw#event#connect#button_press ~callback:
136 if GdkEvent.Button.button ev = 2 then self#paste ();
139 textw#connect#destroy ~callback:self#kill;
140 GMain.Timeout.add ~ms:100 ~callback:
144 ~f:(fun fd -> while self#read ~fd ~len:1024 = 1024 do () done);
151 (* Specific use of shell, for LablBrowser *)
153 let shells : (string * shell) list ref = ref []
155 (* Called before exiting *)
157 List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill ());
159 let _ = at_exit kill_all
162 let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in
167 try Unix.access prog ~perm:[Unix.X_OK]; true
168 with Unix.Unix_error _ -> false
172 List.filter ~f:((<>) "") (Str.split ~sep:(Str.regexp " ") prog) in
173 if progargs = [] then () else
174 let prog = List.hd progargs in
175 let path = try Sys.getenv "PATH" with Not_found -> "/bin:/usr/bin" in
176 let exec_path = Str.split ~sep:(Str.regexp":") path in
178 if not (Filename.is_implicit prog) then
179 if may_exec prog then prog else ""
181 List.fold_left exec_path ~init:"" ~f:
183 if acc <> "" then acc else
184 let prog = Filename.concat dir prog in
185 if may_exec prog then prog else acc
188 if prog = "" then () else
189 let reg = Str.regexp "TERM=" in
190 let env = Array.map (Unix.environment ()) ~f:
192 if Str.string_match ~pat:reg s ~pos:0 then "TERM=dumb" else s
195 List.flatten (List.map !Config.load_path ~f:(fun dir -> ["-I"; dir])) in
196 let args = Array.of_list (progargs @ load_path) in
197 let current_dir = ref (Unix.getcwd ()) in
199 let tl = GWindow.window ~title ~width:500 ~height:300 () in
200 let vbox = GPack.vbox ~packing:tl#add () in
201 let menus = GMenu.menu_bar ~packing:vbox#pack () in
202 let f = new GMenu.factory menus in
203 let accel_group = f#accel_group in
204 let file_menu = f#add_submenu "File"
205 and history_menu = f#add_submenu "History"
206 and signal_menu = f#add_submenu "Signal" in
208 let hbox = GPack.hbox ~packing:vbox#add () in
209 let sh = new shell ~prog ~env ~args ~packing:hbox#add () in
211 GRange.scrollbar `VERTICAL ~adjustment:sh#text#vadjustment
212 ~packing:hbox#pack ()
215 let f = new GMenu.factory file_menu ~accel_group in
216 f#add_item "Use..." ~callback:
218 File.dialog ~title:"Use File" ~filename:(!current_dir ^ "/") () ~callback:
220 current_dir := Filename.dirname name;
221 if Filename.check_suffix name ".ml" then
222 let cmd = "#use \"" ^ name ^ "\";;\n" in
227 f#add_item "Load..." ~callback:
229 File.dialog ~title:"Load File" ~filename:(!current_dir ^ "/") () ~callback:
231 current_dir := Filename.dirname name;
232 if Filename.check_suffix name ".cmo" or
233 Filename.check_suffix name ".cma"
235 let cmd = Printf.sprintf "#load \"%s\";;\n" name in
240 f#add_item "Import path" ~callback:
242 List.iter (List.rev !Config.load_path)
243 ~f:(fun dir -> sh#send (sprintf "#directory \"%s\";;\n" dir))
245 f#add_item "Close" ~key:_W ~callback:tl#destroy;
247 let h = new GMenu.factory history_menu ~accel_group ~accel_modi:[`MOD1] in
248 h#add_item "Previous" ~key:_P ~callback:(fun () -> sh#history `previous);
249 h#add_item "Next" ~key:_N ~callback:(fun () -> sh#history `next);
250 let s = new GMenu.factory signal_menu ~accel_group in
251 s#add_item "Interrupt" ~key:_G ~callback:sh#interrupt;
252 s#add_item "Kill" ~callback:sh#kill;
253 shells := (title, sh) :: !shells;
254 tl#add_accel_group accel_group;