helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/shell.ml

   1 (* $Id$ *)
   2
   3 open GdkKeysyms
   4 open Printf
   5
   6 (* Nice history class. May reuse *)
   7
   8 class ['a] history () = object
   9   val mutable history = ([] : 'a list)
  10   val mutable count = 0
  11   method empty = history = []
  12   method add s = count <- 0; history <- s :: history
  13   method previous =
  14     let s = List.nth history count in
  15     count <- (count + 1) mod List.length history;
  16     s
  17   method next =
  18     let l = List.length history in
  19     count <- (l + count - 1) mod l;
  20     List.nth history ((l + count - 1) mod l)
  21 end
  22
  23 (* The shell class. Now encapsulated *)
  24
  25 let protect f x = try f x with _ -> ()
  26
  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
  32 object (self)
  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
  41   method text = textw
  42   method alive = alive
  43   method kill () =
  44     textw#set_editable false;
  45     if alive then begin
  46       alive <- false;
  47       protect close_out out;
  48       List.iter ~f:(protect Unix.close) [in1; err1; in2; out2; err2];
  49       try
  50         Unix.kill ~pid ~signal:Sys.sigkill;
  51         Unix.waitpid pid ~mode:[]; ()
  52       with _ -> ()
  53     end
  54   method interrupt () =
  55     if alive then try
  56       reading <- false;
  57       Unix.kill ~pid ~signal:Sys.sigint
  58     with Unix.Unix_error _ -> ()
  59   method send s =
  60     if alive then try
  61       output_string out s;
  62       flush out
  63     with Sys_error _ -> ()
  64   method private read ~fd ~len =
  65     try
  66       let buf = String.create len in
  67       let len = Unix.read fd ~buf ~pos:0 ~len in
  68       if len > 0 then begin
  69         textw#set_position textw#length;
  70         self#insert (String.sub buf ~pos:0 ~len);
  71         input_start <- textw#position;
  72       end;
  73       len
  74     with Unix.Unix_error _ -> 0
  75   method history (dir : [`next|`previous]) =
  76     if not h#empty then begin
  77       if reading then begin
  78         textw#delete_text ~start:input_start ~stop:textw#position;
  79       end else begin
  80         reading <- true;
  81         input_start <- textw#position
  82       end;
  83       self#insert (if dir = `previous then h#previous else h#next);
  84     end
  85   val mutable lexing = false
  86   method private lex ~start ~stop:e =
  87     if not lexing && start < e then begin
  88       lexing <- true;
  89       Lexical.tag textw ~start ~stop:e;
  90       lexing <- false
  91     end
  92   method insert ?(lex=true) text =
  93     let start = Text.line_start textw in
  94     textw#insert text;
  95     if lex then self#lex ~start ~stop:(Text.line_end textw)
  96   method private keypress c =
  97     if not reading & c > " " then begin
  98       reading <- true;
  99       input_start <- textw#position
 100     end
 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
 106     h#add s;
 107     self#send s;
 108     self#send "\n"
 109   method private paste () =
 110     if not reading then begin
 111       reading <- true;
 112       input_start <- textw#position;
 113     end
 114   initializer
 115     textw#event#connect#key_press ~callback:
 116       begin fun ev ->
 117         if GdkEvent.Key.keyval ev = _Return && GdkEvent.Key.state ev = []
 118         then self#return ()
 119         else self#keypress (GdkEvent.Key.string ev);
 120         false
 121       end;
 122     textw#connect#after#insert_text ~callback:
 123       begin fun s ~pos ->
 124         if not lexing then
 125           self#lex ~start:(Text.line_start textw ~pos:(pos - String.length s))
 126             ~stop:(Text.line_end textw ~pos)
 127       end;
 128     textw#connect#after#delete_text ~callback:
 129       begin fun ~start:pos ~stop ->
 130         if not lexing then
 131           self#lex ~start:(Text.line_start textw ~pos)
 132             ~stop:(Text.line_end textw ~pos)
 133       end;
 134     textw#event#connect#button_press ~callback:
 135       begin fun ev ->
 136         if GdkEvent.Button.button ev = 2 then self#paste ();
 137         false
 138       end;
 139     textw#connect#destroy ~callback:self#kill;
 140     GMain.Timeout.add ~ms:100 ~callback:
 141       begin fun () ->
 142         if alive then begin
 143           List.iter [err1;in1]
 144             ~f:(fun fd -> while self#read ~fd ~len:1024 = 1024 do () done);
 145           true
 146         end else false
 147       end;
 148     ()
 149 end
 150
 151 (* Specific use of shell, for LablBrowser *)
 152
 153 let shells : (string * shell) list ref = ref []
 154
 155 (* Called before exiting *)
 156 let kill_all () =
 157   List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill ());
 158   shells := []
 159 let _ = at_exit kill_all
 160
 161 let get_all () =
 162   let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in
 163   shells := all;
 164   all
 165
 166 let may_exec prog =
 167   try Unix.access prog ~perm:[Unix.X_OK]; true
 168   with Unix.Unix_error _ -> false
 169
 170 let f ~prog ~title =
 171   let progargs =
 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
 177   let prog =
 178     if not (Filename.is_implicit prog) then
 179       if may_exec prog then prog else ""
 180     else
 181       List.fold_left exec_path ~init:"" ~f:
 182         begin fun acc dir ->
 183           if acc <> "" then acc else
 184           let prog = Filename.concat dir prog in
 185           if may_exec prog then prog else acc
 186         end
 187   in
 188   if prog = "" then () else
 189   let reg = Str.regexp "TERM=" in
 190   let env = Array.map (Unix.environment ()) ~f:
 191       begin fun s ->
 192         if Str.string_match ~pat:reg s ~pos:0 then "TERM=dumb" else s
 193       end in
 194   let load_path =
 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
 198
 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
 207
 208   let hbox = GPack.hbox ~packing:vbox#add () in
 209   let sh = new shell ~prog ~env ~args ~packing:hbox#add () in
 210   let sb =
 211     GRange.scrollbar `VERTICAL ~adjustment:sh#text#vadjustment
 212       ~packing:hbox#pack ()
 213   in
 214
 215   let f = new GMenu.factory file_menu ~accel_group in
 216   f#add_item "Use..." ~callback:
 217     begin fun () ->
 218       File.dialog ~title:"Use File" ~filename:(!current_dir ^ "/") () ~callback:
 219         begin fun name ->
 220           current_dir := Filename.dirname name;
 221           if Filename.check_suffix name ".ml" then
 222             let cmd = "#use \"" ^ name ^ "\";;\n" in
 223             sh#insert cmd;
 224             sh#send cmd
 225         end
 226     end;
 227   f#add_item "Load..." ~callback:
 228     begin fun () ->
 229       File.dialog ~title:"Load File" ~filename:(!current_dir ^ "/") () ~callback:
 230         begin fun name ->
 231           current_dir := Filename.dirname name;
 232           if Filename.check_suffix name ".cmo" or
 233             Filename.check_suffix name ".cma"
 234           then
 235             let cmd = Printf.sprintf "#load \"%s\";;\n" name in
 236             sh#insert cmd;
 237             sh#send cmd
 238         end
 239     end;
 240   f#add_item "Import path" ~callback:
 241     begin fun () ->
 242       List.iter (List.rev !Config.load_path)
 243         ~f:(fun dir -> sh#send (sprintf "#directory \"%s\";;\n" dir))
 244     end;
 245   f#add_item "Close" ~key:_W ~callback:tl#destroy;
 246
 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;
 255   tl#show ()