summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/browser
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/browser')
-rw-r--r--otherlibs/labltk/browser/.cvsignore1
-rw-r--r--otherlibs/labltk/browser/Makefile6
-rw-r--r--otherlibs/labltk/browser/Makefile.nt52
-rw-r--r--otherlibs/labltk/browser/dummyUnix.mli32
-rw-r--r--otherlibs/labltk/browser/dummyWin.mli14
-rw-r--r--otherlibs/labltk/browser/jg_config.ml9
-rw-r--r--otherlibs/labltk/browser/shell.ml116
7 files changed, 206 insertions, 24 deletions
diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore
index f3f03276e..8ced21de2 100644
--- a/otherlibs/labltk/browser/.cvsignore
+++ b/otherlibs/labltk/browser/.cvsignore
@@ -1 +1,2 @@
ocamlbrowser
+dummy.mli
diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile
index 9dfed9517..7f2875703 100644
--- a/otherlibs/labltk/browser/Makefile
+++ b/otherlibs/labltk/browser/Makefile
@@ -40,9 +40,13 @@ install:
if test -f ocamlbrowser; then : ; cp ocamlbrowser $(BINDIR); fi
clean:
- rm -f *.cm? ocamlbrowser *~ *.orig
+ rm -f *.cm? ocamlbrowser dummy.mli *~ *.orig
depend:
$(LABLDEP) *.ml *.mli > .depend
+dummy.mli:
+ ln -sf dummyUnix.mli dummy.mli
+shell.cmo: dummy.cmi
+
include .depend
diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt
new file mode 100644
index 000000000..8b67c8f2e
--- /dev/null
+++ b/otherlibs/labltk/browser/Makefile.nt
@@ -0,0 +1,52 @@
+!include ..\support\Makefile.common.nt
+
+LABLTKLIB=-I ../lib -I ../support
+OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str -I $(OTHERS)/systhreads
+OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing
+INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB)
+CLIBS=../support/liblabltk41.lib $(OTHERS)/str/libstr.lib $(OTHERS)/win32unix/libunix.lib $(OTHERS)/systhreads/libthreads.lib
+
+OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
+ fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \
+ viewer.cmo typecheck.cmo editor.cmo main.cmo
+
+JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \
+ jg_box.cmo \
+ jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \
+ jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo
+
+# Default rules
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+ $(LABLCOMP) $(INCLUDES) $<
+
+.mli.cmi:
+ $(LABLCOMP) $(INCLUDES) $<
+
+all: ocamlbrowser
+
+ocamlbrowser: $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ)
+ $(LABLC) -custom -o ocamlbrowser $(INCLUDES) \
+ $(TOPDIR)/toplevel/toplevellib.cma \
+ unix.cma threads.cma str.cma tk41.cma jglib.cma $(OBJ) \
+ -cclib "$(CLIBS)" $(TKLINKOPT)
+
+jglib.cma: $(JG)
+ $(LABLCOMP) -a -o jglib.cma $(JG)
+
+install:
+ if exist ocamlbrowser.exe cp ocamlbrowser.exe $(BINDIR)
+
+clean:
+ rm -f *.cm? ocamlbrowser dummy.mli *~ *.orig
+
+depend:
+ $(LABLDEP) *.ml *.mli > .depend
+
+dummy.mli:
+ cp dummyWin.mli dummy.mli
+shell.cmo: dummy.cmi
+
+!include .depend
diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
new file mode 100644
index 000000000..b2ce9e04d
--- /dev/null
+++ b/otherlibs/labltk/browser/dummyUnix.mli
@@ -0,0 +1,32 @@
+(*************************************************************************)
+(* *)
+(* Objective Caml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+module Mutex : sig
+ type t
+ external create : unit -> t = "%ignore"
+ external lock : t -> unit = "%ignore"
+ external unlock : t -> unit = "%ignore"
+end
+
+module Thread : sig
+ type t
+ external create : ('a -> 'b) -> 'a -> t = "caml_input"
+end
+
+module ThreadUnix : sig
+ open Unix
+ external read : file_descr -> buf:string -> pos:int -> len:int -> int
+ = "caml_input"
+end
diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli
new file mode 100644
index 000000000..124ada5eb
--- /dev/null
+++ b/otherlibs/labltk/browser/dummyWin.mli
@@ -0,0 +1,14 @@
+(*************************************************************************)
+(* *)
+(* Objective Caml LablTk library *)
+(* *)
+(* Jacques Garrigue, Kyoto University RIMS *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License. *)
+(* *)
+(*************************************************************************)
+
+(* $Id$ *)
diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml
index 63df1387b..49500e2fc 100644
--- a/otherlibs/labltk/browser/jg_config.ml
+++ b/otherlibs/labltk/browser/jg_config.ml
@@ -13,14 +13,21 @@
(* $Id$ *)
+let fixed =
+ if Sys.os_type = "Win32" then "{Courier New} 8" else "fixed"
+let variable =
+ if Sys.os_type = "Win32" then "Arial 9" else "variable"
+
let init () =
+ if Sys.os_type = "Win32" then Option.add path:"*font" fixed;
let font =
let font =
Option.get Widget.default_toplevel name:"variableFont" class:"Font" in
- if font = "" then "variable" else font
+ if font = "" then variable else font
in
List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"]
fun:(fun cl -> Option.add path:("*" ^ cl ^ ".font") font);
+ Option.add path:"*Menu.tearOff" "0" priority:`StartupFile;
Option.add path:"*Button.padY" "0" priority:`StartupFile;
Option.add path:"*Text.highlightThickness" "0" priority:`StartupFile;
Option.add path:"*interface.background" "gray85" priority:`StartupFile;
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 7b27b89a7..f2fbd3a7e 100644
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -15,6 +15,7 @@
open Tk
open Jg_tk
+open Dummy
(* Here again, memoize regexps *)
@@ -37,6 +38,19 @@ class ['a] history () = object
List.nth history pos:((l + count - 1) mod l)
end
+let dump_mem ?(:pos = 0) ?:len obj =
+ if not (Obj.is_block obj) then invalid_arg "Shell.dump_mem";
+ let len =
+ match len with
+ | None -> Obj.size obj * Sys.word_size / 8 - pos
+ | Some x -> x in
+ let buf = Buffer.create 256 in
+ for i = pos to len - 1 do
+ let c = String.unsafe_get (Obj.obj obj) i in
+ Buffer.add_string buf (Printf.sprintf "%02x" (Char.code c))
+ done;
+ Buffer.contents buf
+
(* The shell class. Now encapsulated *)
let protect f x = try f x with _ -> ()
@@ -44,32 +58,52 @@ 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
+ and (err1,err2) = Unix.pipe ()
+ and (sig2,sig1) = Unix.pipe () in
object (self)
- val pid = Unix.create_process_env name:prog :args :env
+ val pid =
+ let env =
+ if Sys.os_type = "Win32" then
+ let sigdef = "CAMLSIGPIPE=" ^ dump_mem (Obj.repr sig2) in
+ Array.append env [|sigdef|]
+ else env
+ in
+ Unix.create_process_env name:prog :args :env
stdin:in2 stdout:out2 stderr:err2
val out = Unix.out_channel_of_descr out1
val h = new history ()
val mutable alive = true
val mutable reading = false
+ val ibuffer = Buffer.create 1024
+ val imutex = Mutex.create ()
+ val mutable ithreads = []
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 mode:[] pid; ()
+ if Sys.os_type = "Win32" then begin
+ ignore (Unix.write sig1 buf:"T" pos:0 len:1);
+ List.iter fun:(protect Unix.close) [sig1; sig2]
+ end else begin
+ List.iter fun:(protect Unix.close) [in1; err1; sig1; sig2];
+ Fileevent.remove_fileinput fd:in1;
+ Fileevent.remove_fileinput fd:err1;
+ Unix.kill :pid signal:Sys.sigkill;
+ Unix.waitpid mode:[] pid; ()
+ end
with _ -> ()
end
method interrupt =
if alive then try
reading <- false;
- Unix.kill :pid signal:Sys.sigint
+ if Sys.os_type = "Win32" then begin
+ ignore (Unix.write sig1 buf:"C" pos:0 len:1);
+ self#send " "
+ end else
+ Unix.kill :pid signal:Sys.sigint
with Unix.Unix_error _ -> ()
method send s =
if alive then try
@@ -77,12 +111,16 @@ object (self)
flush out
with Sys_error _ -> ()
method private read :fd :len =
- try
+ begin try
let buf = String.create :len in
let len = Unix.read fd :buf pos:0 :len in
- self#insert (String.sub buf pos:0 :len);
- Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
- with Unix.Unix_error _ -> ()
+ if len > 0 then begin
+ self#insert (String.sub buf pos:0 :len);
+ Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+ end;
+ len
+ with Unix.Unix_error _ -> 0
+ end;
method history (dir : [`next|`previous]) =
if not h#empty then begin
if reading then begin
@@ -151,13 +189,38 @@ object (self)
end;
bind textw events:[`KeyPressDetail"Return"] breakable:true
action:(fun _ -> self#return; break());
- begin try
- List.iter [in1;err1] fun:
- begin fun fd ->
- Fileevent.add_fileinput :fd
- callback:(fun () -> self#read :fd len:1024)
- end
- with _ -> ()
+ List.iter fun:Unix.close [in2;out2;err2];
+ if Sys.os_type = "Win32" then begin
+ let fileinput_thread fd =
+ let buf = String.create len:1024 in
+ let len = ref 0 in
+ try while len := ThreadUnix.read fd :buf pos:0 len:1024; !len > 0 do
+ Mutex.lock imutex;
+ Buffer.add_substring ibuffer buf pos:0 len:!len;
+ Mutex.unlock imutex
+ done with Unix.Unix_error _ -> ()
+ in
+ ithreads <- List.map [in1; err1] fun:(Thread.create fileinput_thread);
+ let rec read_buffer () =
+ Mutex.lock imutex;
+ if Buffer.length ibuffer > 0 then begin
+ self#insert (Str.global_replace pat:~"\r\n" with:"\n"
+ (Buffer.contents ibuffer));
+ Buffer.reset ibuffer;
+ Text.mark_set textw mark:"input" index:(`Mark"insert",[`Char(-1)])
+ end;
+ Mutex.unlock imutex;
+ ignore (Timer.add ms:100 callback:read_buffer)
+ in
+ read_buffer ()
+ end else begin
+ try
+ List.iter [in1;err1] fun:
+ begin fun fd ->
+ Fileevent.add_fileinput :fd
+ callback:(fun () -> ignore (self#read :fd len:1024))
+ end
+ with _ -> ()
end
end
@@ -175,17 +238,26 @@ let get_all () =
shells := all;
all
-let may_exec prog =
+let may_exec_unix prog =
try Unix.access name:prog perm:[Unix.X_OK]; true
with Unix.Unix_error _ -> false
+let may_exec_win prog =
+ List.exists pred:may_exec_unix [prog; prog^".exe"; prog^".cmo"; prog^".bat"]
+
+let may_exec =
+ if Sys.os_type = "Win32" then may_exec_win else may_exec_unix
+
+let path_sep = if Sys.os_type = "Win32" then ";" else ":"
+
let f :prog :title =
let progargs =
List.filter pred:((<>) "") (Str.split sep:~" " 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:~":" path in
+ let path =
+ try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in
+ let exec_path = Str.split sep:~path_sep path in
let exists =
if not (Filename.is_implicit prog) then may_exec prog else
List.exists exec_path
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 02:40:58 +0000