summaryrefslogtreecommitdiff
path: root/otherlibs/labltk/jpf
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/jpf')
-rw-r--r--otherlibs/labltk/jpf/Makefile77
-rw-r--r--otherlibs/labltk/jpf/Makefile.nt75
-rw-r--r--otherlibs/labltk/jpf/README2
-rw-r--r--otherlibs/labltk/jpf/balloon.ml102
-rw-r--r--otherlibs/labltk/jpf/balloon.mli24
-rw-r--r--otherlibs/labltk/jpf/balloontest.ml32
-rw-r--r--otherlibs/labltk/jpf/fileselect.ml368
-rw-r--r--otherlibs/labltk/jpf/fileselect.mli37
-rw-r--r--otherlibs/labltk/jpf/jpf_font.ml218
-rw-r--r--otherlibs/labltk/jpf/jpf_font.mli54
-rw-r--r--otherlibs/labltk/jpf/shell.ml36
-rw-r--r--otherlibs/labltk/jpf/shell.mli17
12 files changed, 0 insertions, 1042 deletions
diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile
deleted file mode 100644
index 1c499356d5..0000000000
--- a/otherlibs/labltk/jpf/Makefile
+++ /dev/null
@@ -1,77 +0,0 @@
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str
-
-OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: jpflib.cma
-
-opt: jpflib.cmxa
-
-test: balloontest
-
-testopt: balloontest.opt
-
-jpflib.cma: $(OBJS)
- $(CAMLLIBR) -o jpflib.cma $(OBJS)
-
-jpflib.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX)
-
-install: jpflib.cma
- cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR)
-
-installopt: jpflib.cmxa
- cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR)
-
-clean:
- rm -f *.cm* *.o *.a *~ *test
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-### Tests
-
-balloontest: balloontest.cmo
- $(CAMLC) -o balloontest -I ../support -I ../lib \
- -custom $(LIBNAME).cma jpflib.cma balloontest.cmo
-
-balloontest.opt: balloontest.cmx
- $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \
- $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx
-
-balloontest.cmo : balloon.cmo jpflib.cma
-
-balloontest.cmx : balloon.cmx jpflib.cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- mv Makefile Makefile.bak
- (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \
- $(CAMLDEP) *.mli *.ml) > Makefile
-
-
-### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED
-### DO NOT DELETE THIS LINE
-balloon.cmo: balloon.cmi
-balloon.cmx: balloon.cmi
-fileselect.cmo: fileselect.cmi
-fileselect.cmx: fileselect.cmi
-jpf_font.cmo: shell.cmi jpf_font.cmi
-jpf_font.cmx: shell.cmx jpf_font.cmi
-shell.cmo: shell.cmi
-shell.cmx: shell.cmi
diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt
deleted file mode 100644
index 7501a01d4b..0000000000
--- a/otherlibs/labltk/jpf/Makefile.nt
+++ /dev/null
@@ -1,75 +0,0 @@
-include ../support/Makefile.common.nt
-
-COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str
-
-OBJS= fileselect.cmo balloon.cmo
-
-OBJSX = $(OBJS:.cmo=.cmx)
-
-all: libjpf.cma
-
-opt: libjpf.cmxa
-
-test: balloontest
-
-testopt: balloontest.opt
-
-libjpf.cma: $(OBJS)
- $(CAMLLIBR) -o libjpf.cma $(OBJS)
-
-libjpf.cmxa: $(OBJSX)
- $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX)
-
-install: libjpf.cma
- cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR)
-
-installopt: libjpf.cmxa
- cp libjpf.cmxa libjpf.$(A) $(INSTALLDIR)
-
-clean:
- rm -f *.cm* *.$(O) *.$(A) *~ *test
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJSX): ../lib/$(LIBNAME).cmxa
-
-### Tests
-
-balloontest: balloontest.cmo
- $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \
- -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT)
-
-balloontest.opt: balloontest.cmx
- $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \
- $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT)
-
-balloontest.cmo : balloon.cmo libjpf.cma
-
-balloontest.cmx : balloon.cmx libjpf.cmxa
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmx .cmo
-
-.mli.cmi:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
- $(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
- $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend:
- mv Makefile Makefile.bak
- (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \
- $(CAMLDEP) *.mli *.ml) > Makefile
-
-
-### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED
-### DO NOT DELETE THIS LINE
-balloon.cmo: balloon.cmi
-balloon.cmx: balloon.cmi
-balloontest.cmo: balloon.cmi
-balloontest.cmx: balloon.cmx
-fileselect.cmo: fileselect.cmi
-fileselect.cmx: fileselect.cmi
diff --git a/otherlibs/labltk/jpf/README b/otherlibs/labltk/jpf/README
deleted file mode 100644
index 275c2d7803..0000000000
--- a/otherlibs/labltk/jpf/README
+++ /dev/null
@@ -1,2 +0,0 @@
-This is Jun Furuse's widget set library, Jpf.
-It uses LablTk API.
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
deleted file mode 100644
index 6b2f36d209..0000000000
--- a/otherlibs/labltk/jpf/balloon.ml
+++ /dev/null
@@ -1,102 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open StdLabels
-
-(* easy balloon help facility *)
-
-open Tk
-open Widget
-open Protocol
-open Support
-
-(* switch -- if you do not want balloons, set false *)
-let flag = ref true
-let debug = ref false
-
-(* We assume we have at most one popup label at a time *)
-let topw = ref default_toplevel
-and popupw = ref (Obj.magic dummy : message widget)
-
-let configure_cursor w cursor =
- (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *)
- Protocol.tkCommand [| TkToken (name w);
- TkToken "configure";
- TkToken "-cursor";
- TkToken cursor |]
-
-let put ~on: w ~ms: millisec mesg =
- let t = ref None in
- let cursor = ref "" in
-
- let reset () =
- begin
- match !t with
- Some t -> Timer.remove t
- | _ -> ()
- end;
- (* if there is a popup label, unmap it *)
- if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then
- begin
- Wm.withdraw !topw;
- if Winfo.exists w then configure_cursor w !cursor
- end
- and set ev =
- if !flag then
- t := Some (Timer.add ~ms: millisec ~callback: (fun () ->
- t := None;
- if !debug then
- prerr_endline ("Balloon: " ^ Widget.name w);
- update_idletasks();
- Message.configure !popupw ~text: mesg;
- raise_window !topw;
- Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *)
- ("+"^(string_of_int (ev.ev_RootX + 9))^
- "+"^(string_of_int (ev.ev_RootY + 8)));
- Wm.deiconify !topw;
- cursor := cget w `Cursor;
- configure_cursor w "hand2"))
- in
-
- List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy];
- [`KeyPress]; [`KeyRelease]]
- ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ()));
- List.iter [[`Enter]; [`Motion]] ~f:
- begin fun events ->
- bind w ~events ~extend:true ~fields:[`RootX; `RootY]
- ~action:(fun ev -> reset (); set ev)
- end
-
-let init () =
- let t = Hashtbl.create 101 in
- Protocol.add_destroy_hook (fun w ->
- Hashtbl.remove t w);
- topw := Toplevel.create default_toplevel;
- Wm.overrideredirect_set !topw true;
- Wm.withdraw !topw;
- popupw := Message.create !topw ~name: "balloon"
- ~background: (`Color "yellow") ~aspect: 300;
- pack [!popupw];
- bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action:
- begin fun w ->
- try Hashtbl.find t w.ev_Widget
- with Not_found ->
- Hashtbl.add t w.ev_Widget ();
- let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
- if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
- end
diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli
deleted file mode 100644
index 633796ce6b..0000000000
--- a/otherlibs/labltk/jpf/balloon.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* easy balloon help facility *)
-open Widget
-
-val flag : bool ref
-val init : unit -> unit
-val put : on: 'a widget -> ms: int -> string -> unit
diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml
deleted file mode 100644
index 36e6c8dbf1..0000000000
--- a/otherlibs/labltk/jpf/balloontest.ml
+++ /dev/null
@@ -1,32 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Tk
-open Widget
-open Balloon
-open Protocol
-
-let _ =
- let t = openTk () in
- Balloon.init ();
- let b = Button.create t ~text: "hello" in
- Button.configure b ~command: (fun () -> destroy b);
- pack [b];
- Balloon.put ~on: b ~ms: 1000 "Balloon";
- Printexc.catch mainLoop ()
-
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
deleted file mode 100644
index ec0e7749f1..0000000000
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ /dev/null
@@ -1,368 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* file selection box *)
-
-(* This file selecter works only under the OS with the full unix support.
- For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
-
-open StdLabels
-open UnixLabels
-open Str
-open Filename
-
-open Tk
-open Widget
-
-exception Not_selected
-
-(********************************************************** Search directory *)
-(* Default is curdir *)
-let global_dir = ref (getcwd ())
-
-(***************************************************** Some widgets creation *)
-
-(* from frx_listbox.ml *)
-let scroll_link sb lb =
- Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb);
- Scrollbar.configure sb ~command: (Listbox.yview lb)
-
-(* focus when enter binding *)
-let bind_enter_focus w =
- bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);;
-
-let myentry_create p ~variable =
- let w = Entry.create p ~relief: `Sunken ~textvariable: variable in
- bind_enter_focus w; w
-
-(************************************************************* Subshell call *)
-
-let subshell cmd =
- let r,w = pipe () in
- match fork () with
- 0 -> close r; dup2 ~src:w ~dst:stdout;
- execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |];
- exit 127
- | id ->
- close w;
- let rc = in_channel_of_descr r in
- let rec it l =
- match
- try Some(input_line rc) with _ -> None
- with
- Some x -> it (x::l)
- | None -> List.rev l
- in
- let answer = it [] in
- close_in rc; (* because of finalize_channel *)
- let p, st = waitpid ~mode:[] id in answer
-
-(***************************************************************** Path name *)
-
-(* find directory name which doesn't contain "?*[" *)
-let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)"
-
-let parse_filter src =
- (* replace // by / *)
- let s = global_replace (regexp "/+") "/" src in
- (* replace /./ by / *)
- let s = global_replace (regexp "/\\./") "/" s in
- (* replace ????/../ by "" *)
- let s = global_replace
- (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./")
- ""
- s in
- (* replace ????/..$ by "" *)
- let s = global_replace
- (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$")
- ""
- s in
- (* replace ^/../../ by / *)
- let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in
- if string_match dirget s 0 then
- let dirs = matched_group 1 s
- and ptrn = matched_group 2 s
- in
- dirs, ptrn
- else "", s
-
-let ls dir pattern =
- subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
-
-(*************************************************************** File System *)
-
-let get_files_in_directory dir =
- let dirh = opendir dir in
- let rec get_them l =
- match
- try Some(Unix.readdir dirh) with _ -> None
- with
- | None ->
- Unix.closedir dirh; l
- | Some x ->
- get_them (x::l)
- in
- List.sort ~cmp:compare (get_them [])
-
-let rec get_directories_in_files path =
- List.filter
- ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
-
-let remove_directories path =
- List.filter
- ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
-
-(************************* a nice interface to listbox - from frx_listbox.ml *)
-
-let add_completion lb action =
- let prefx = ref "" (* current match prefix *)
- and maxi = ref 0 (* maximum index (doesn'y matter actually) *)
- and current = ref 0 (* current position *)
- and lastevent = ref 0 in
-
- let rec move_forward () =
- if Listbox.get lb ~index:(`Num !current) < !prefx then
- if !current < !maxi then begin incr current; move_forward() end
-
- and recenter () =
- let element = `Num !current in
- (* Clean the selection *)
- Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
- (* Set it to our unique element *)
- Listbox.selection_set lb ~first:element ~last:element;
- (* Activate it, to keep consistent with Up/Down.
- You have to be in Extended or Browse mode *)
- Listbox.activate lb ~index:element;
- Listbox.selection_anchor lb ~index:element;
- Listbox.see lb ~index:element in
-
- let complete time s =
- if time - !lastevent < 500 then (* sorry, hard coded limit *)
- prefx := !prefx ^ s
- else begin (* reset *)
- current := 0;
- prefx := s
- end;
- lastevent := time;
- move_forward();
- recenter() in
-
-
- bind lb ~events:[`KeyPress] ~fields:[`Char; `Time]
- (* consider only keys producing characters. The callback is called
- if you press Shift. *)
- ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char);
- (* Key specific bindings override KeyPress *)
- bind lb ~events:[`KeyPressDetail "Return"] ~action;
- (* Finally, we have to set focus, otherwise events dont get through *)
- Focus.set lb;
- recenter() (* so that first item is selected *);
- (* returns init_completion function *)
- (fun lb ->
- prefx := "";
- maxi := Listbox.size lb - 1;
- current := 0)
-
-(****************************************************************** Creation *)
-
-let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync =
- (* Ah ! Now I regret about the names of the widgets... *)
-
- let current_pattern = ref ""
- and current_dir = ref "" in
-
- (* init_completions *)
- let filter_init_completion = ref (fun _ -> ())
- and directory_init_completion = ref (fun _ -> ()) in
-
- let tl = Toplevel.create default_toplevel in
- Focus.set tl;
- Wm.title_set tl title;
-
- let filter_var = Textvariable.create ~on:tl () (* new_temporary *)
- and selection_var = Textvariable.create ~on:tl ()
- and sync_var = Textvariable.create ~on:tl () in
-
- let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
- let frm = Frame.create frm' ~borderwidth: 8 in
- let fl = Label.create frm ~text: "Filter" in
- let df = Frame.create frm in
- let dfl = Frame.create df in
- let dfll = Label.create dfl ~text: "Directories" in
- let dflf = Frame.create dfl in
- let directory_listbox = Listbox.create dflf ~relief: `Sunken
- and directory_scrollbar = Scrollbar.create dflf in
- scroll_link directory_scrollbar directory_listbox;
- let dfr = Frame.create df in
- let dfrl = Label.create dfr ~text: "Files" in
- let dfrf = Frame.create dfr in
- let filter_listbox = Listbox.create dfrf ~relief: `Sunken in
- let filter_scrollbar = Scrollbar.create dfrf in
- scroll_link filter_scrollbar filter_listbox;
- let sl = Label.create frm ~text: "Selection" in
- let filter_entry = myentry_create frm ~variable: filter_var in
- let selection_entry = myentry_create frm ~variable: selection_var
- in
- let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
- let cfrm = Frame.create cfrm' ~borderwidth: 8 in
- let dumf = Frame.create cfrm in
- let dumf2 = Frame.create cfrm in
-
- let configure filter =
- (* OLDER let curdir = getcwd () in *)
-(* Printf.eprintf "CURDIR %s\n" curdir; *)
- let filter =
- if string_match (regexp "^/.*") filter 0 then filter
- else
- if filter = "" then !global_dir ^ "/*"
- else !global_dir ^ "/" ^ filter in
-(* Printf.eprintf "FILTER %s\n" filter; *)
- let dirname, patternname = parse_filter filter in
-(* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *)
- current_dir := dirname;
- global_dir := dirname;
- let patternname = if patternname = "" then "*" else patternname in
- current_pattern := patternname;
- let filter = dirname ^ patternname in
-(* Printf.eprintf "FILTER : %s\n\n" filter; *)
-(* flush Pervasives.stderr; *)
- try
- let directories = get_directories_in_files dirname
- (get_files_in_directory dirname) in
- (* get matched file by subshell call. *)
- let matched_files = remove_directories dirname (ls dirname patternname)
- in
- Textvariable.set filter_var filter;
- Textvariable.set selection_var (dirname ^ deffile);
- Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert directory_listbox ~index:`End ~texts:directories;
- Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
- Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
- !directory_init_completion directory_listbox;
- !filter_init_completion filter_listbox
- with
- Unix_error (ENOENT,_,_) ->
- (* Directory is not found (maybe) *)
- Bell.ring ()
- in
-
- let selected_files = ref [] in (* used for synchronous mode *)
- let activate l () =
- Grab.release tl;
- destroy tl;
- if sync then
- begin
- selected_files := l;
- Textvariable.set sync_var "1"
- end
- else
- begin
- proc l;
- break ()
- end
- in
-
- (* and buttons *)
- let okb = Button.create cfrm ~text: "OK" ~command:
- begin fun () ->
- let files =
- List.map (Listbox.curselection filter_listbox)
- ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
- in
- let files = if files = [] then [Textvariable.get selection_var]
- else files in
- activate files ()
- end
- in
- let flb = Button.create cfrm ~text: "Filter"
- ~command: (fun () -> configure (Textvariable.get filter_var)) in
- let ccb = Button.create cfrm ~text: "Cancel"
- ~command: (fun () -> activate [] ()) in
-
- (* binding *)
- bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true
- ~action:(fun _ -> activate [Textvariable.get selection_var] ());
- bind filter_entry ~events:[`KeyPressDetail "Return"]
- ~action:(fun _ -> configure (Textvariable.get filter_var));
-
- let action _ =
- let files =
- List.map (Listbox.curselection filter_listbox)
- ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
- in
- activate files ()
- in
- bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~breakable:true ~action;
- if multi then Listbox.configure filter_listbox ~selectmode: `Multiple;
- filter_init_completion := add_completion filter_listbox action;
-
- let action _ =
- try
- configure (!current_dir ^ ((function
- [x] -> Listbox.get directory_listbox ~index:x
- | _ -> (* you must choose at least one directory. *)
- Bell.ring (); raise Not_selected)
- (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern)
- with _ -> () in
- bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
- ~breakable:true ~action;
- Listbox.configure directory_listbox ~selectmode: `Browse;
- directory_init_completion := add_completion directory_listbox action;
-
- pack [frm'; frm] ~fill: `X;
- (* filter *)
- pack [fl] ~side: `Top ~anchor: `W;
- pack [filter_entry] ~side: `Top ~fill: `X;
- (* directory + files *)
- pack [df] ~side: `Top ~fill: `X ~ipadx: 8;
- (* directory *)
- pack [dfl] ~side: `Left;
- pack [dfll] ~side: `Top ~anchor: `W;
- pack [dflf] ~side: `Top;
- pack [coe directory_listbox; coe directory_scrollbar]
- ~side: `Left ~fill: `Y;
- (* files *)
- pack [dfr] ~side: `Right;
- pack [dfrl] ~side: `Top ~anchor: `W;
- pack [dfrf] ~side: `Top;
- pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y;
- (* selection *)
- pack [sl] ~side: `Top ~anchor: `W;
- pack [selection_entry] ~side: `Top ~fill: `X;
-
- (* create OK, Filter and Cancel buttons *)
- pack [cfrm'] ~fill: `X;
- pack [cfrm] ~fill: `X;
- pack [okb] ~side: `Left;
- pack [dumf] ~side: `Left ~expand: true;
- pack [flb] ~side: `Left;
- pack [dumf2] ~side: `Left ~expand: true;
- pack [ccb] ~side: `Left;
-
- configure deffilter;
-
- Tkwait.visibility tl;
- Grab.set tl;
-
- if sync then
- begin
- Tkwait.variable sync_var;
- proc !selected_files
- end;
- ()
diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli
deleted file mode 100644
index 79dc828f94..0000000000
--- a/otherlibs/labltk/jpf/fileselect.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* This file selecter works only under the OS with the full unix support.
- For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
-
-open Support
-
-val f :
- title:string ->
- action:(string list -> unit) ->
- filter:string -> file:string -> multi:bool -> sync:bool -> unit
-
-(* action
- [] means canceled
- if multi select is false, then the list is null or a singleton *)
-
-(* multi select
- if true then more than one file are selectable *)
-
-(* sync it
- if true then in synchronous mode *)
diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml
deleted file mode 100644
index c9c3d05267..0000000000
--- a/otherlibs/labltk/jpf/jpf_font.ml
+++ /dev/null
@@ -1,218 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-(* find font information *)
-
-let debug = ref false
-let log s =
- if !debug then try prerr_endline s with _ -> ()
-
-type ('s, 'i) xlfd = {
- (* some of them are currently not interesting for me *)
- mutable foundry: 's;
- mutable family: 's;
- mutable weight: 's;
- mutable slant: 's;
- mutable setWidth: 's;
- mutable addStyle: 's;
- mutable pixelSize: 'i;
- mutable pointSize: 'i;
- mutable resolutionX: 'i;
- mutable resolutionY: 'i;
- mutable spacing: 's;
- mutable averageWidth: 'i;
- mutable registry: 's;
- mutable encoding: 's
- }
-
-let copy xlfd = {xlfd with foundry= xlfd.foundry}
-
-let string_of_xlfd s i xlfd =
- let foundry= s xlfd.foundry
- and family= s xlfd.family
- and weight= s xlfd.weight
- and slant= s xlfd.slant
- and setWidth = s xlfd.setWidth
- and addStyle = s xlfd.addStyle
- and pixelSize= i xlfd.pixelSize
- and pointSize = i xlfd.pointSize
- and resolutionX = i xlfd.resolutionX
- and resolutionY = i xlfd.resolutionY
- and spacing= s xlfd.spacing
- and averageWidth = i xlfd.averageWidth
- and registry= s xlfd.registry
- and encoding = s xlfd.encoding in
-
- "-"^foundry^
- "-"^family^
- "-"^weight^
- "-"^slant^
- "-"^setWidth ^
- "-"^addStyle ^
- "-"^pixelSize^
- "-"^pointSize ^
- "-"^resolutionX ^
- "-"^resolutionY ^
- "-"^spacing^
- "-"^averageWidth ^
- "-"^registry^
- "-"^encoding
-
-exception Parse_Xlfd_Failure of string
-
-let parse_xlfd xlfd_string =
- (* this must not be a pattern *)
- let split_str char_sep str =
- let len = String.length str in
- let rec split beg cur =
- if cur >= len then [String.sub str beg (len - beg)]
- else if char_sep (String.get str cur)
- then
- let nextw = succ cur in
- (String.sub str beg (cur - beg))
- ::(split nextw nextw)
- else split beg (succ cur) in
- split 0 0
- in
- match split_str (function '-' -> true | _ -> false) xlfd_string with
- | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize;
- pointSize; resolutionX; resolutionY; spacing; averageWidth;
- registry; encoding ] ->
- { foundry= foundry;
- family= family;
- weight= weight;
- slant= slant;
- setWidth= setWidth;
- addStyle= addStyle;
- pixelSize= int_of_string pixelSize;
- pointSize= int_of_string pointSize;
- resolutionX= int_of_string resolutionX;
- resolutionY= int_of_string resolutionY;
- spacing= spacing;
- averageWidth= int_of_string averageWidth;
- registry= registry;
- encoding= encoding;
- }
- | _ -> raise (Parse_Xlfd_Failure xlfd_string)
-
-type valid_xlfd = (string, int) xlfd
-
-let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int
-
-type pattern = (string option, int option) xlfd
-
-let empty_pattern =
- { foundry= None;
- family= None;
- weight= None;
- slant= None;
- setWidth= None;
- addStyle= None;
- pixelSize= None;
- pointSize= None;
- resolutionX= None;
- resolutionY= None;
- spacing= None;
- averageWidth= None;
- registry= None;
- encoding= None;
- }
-
-let string_of_pattern =
- let pat f = function
- Some x -> f x
- | None -> "*"
- in
- let pat_string = pat (fun x -> x) in
- let pat_int = pat string_of_int in
- string_of_xlfd pat_string pat_int
-
-let is_vector_font xlfd =
- (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) ||
- xlfd.spacing <> "c"
-
-let list_fonts dispname pattern =
- let dispopt = match dispname with
- None -> ""
- | Some x -> "-display " ^ x
- in
- let result = List.map parse_xlfd
- (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern))
- in
- if result = [] then raise Not_found
- else result
-
-let available_pixel_size_aux dispname pattern =
- (* return available pixel size without font resizing *)
- (* to obtain good result, *)
- (* the pattern should contain as many information as possible *)
- let pattern = copy pattern in
- pattern.pixelSize <- None;
- let xlfds = list_fonts dispname pattern in
- let pxszs = Hashtbl.create 107 in
- List.iter (fun xlfd ->
- Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds;
- pxszs
-
-let extract_size_font_hash tbl =
- let keys = ref [] in
- Hashtbl.iter (fun k _ ->
- if not (List.mem k !keys) then keys := k :: !keys) tbl;
- Sort.list (fun (k1,_) (k2,_) -> k1 < k2)
- (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys)
-
-let available_pixel_size dispname pattern =
- let pxszs = available_pixel_size_aux dispname pattern in
- extract_size_font_hash pxszs
-
-let nearest_pixel_size dispname vector_ok pattern =
- (* find the font with the nearest pixel size *)
- log ("\n*** "^string_of_pattern pattern);
- let pxlsz =
- match pattern.pixelSize with
- None -> raise (Failure "invalid pixelSize pattern")
- | Some x -> x
- in
- let tbl = available_pixel_size_aux dispname pattern in
- let newtbl = Hashtbl.create 107 in
- Hashtbl.iter (fun s xlfd ->
- if vector_ok then
- if s = 0 then begin
- if is_vector_font xlfd then begin
- log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd));
- xlfd.pixelSize <- pxlsz;
- Hashtbl.add newtbl pxlsz xlfd
- end
- end else Hashtbl.add newtbl s xlfd
- else if not (is_vector_font xlfd) && s <> 0 then
- Hashtbl.add newtbl s xlfd) tbl;
-
- let size_font_table = extract_size_font_hash newtbl in
-
- let diff = ref 10000 in
- let min = ref None in
- List.iter (fun (s,xlfds) ->
- let d = abs(s - pxlsz) in
- if d < !diff then begin
- min := Some (s,xlfds);
- diff := d
- end) size_font_table;
- (* if it contains more than one font, just return the first *)
- match !min with
- | None -> raise Not_found
- | Some(s, xlfds) ->
- log (Printf.sprintf "Size %d is selected" s);
- List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds;
- List.hd xlfds
diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli
deleted file mode 100644
index cd1e212297..0000000000
--- a/otherlibs/labltk/jpf/jpf_font.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val debug : bool ref
-
-type ('a, 'b) xlfd =
- { mutable foundry: 'a;
- mutable family: 'a;
- mutable weight: 'a;
- mutable slant: 'a;
- mutable setWidth: 'a;
- mutable addStyle: 'a;
- mutable pixelSize: 'b;
- mutable pointSize: 'b;
- mutable resolutionX: 'b;
- mutable resolutionY: 'b;
- mutable spacing: 'a;
- mutable averageWidth: 'b;
- mutable registry: 'a;
- mutable encoding: 'a }
-
-exception Parse_Xlfd_Failure of string
-
-type valid_xlfd = (string, int) xlfd
-type pattern = (string option, int option) xlfd
-
-val empty_pattern : pattern
-
-val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd
-
-val string_of_valid_xlfd : valid_xlfd -> string
-val string_of_pattern : pattern -> string
-
-val is_vector_font : valid_xlfd -> bool
-
-val list_fonts : string option -> pattern -> valid_xlfd list
-
-val available_pixel_size :
- string option -> pattern -> (int * valid_xlfd list) list
-
-val nearest_pixel_size :
- string option -> bool -> pattern -> valid_xlfd
diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml
deleted file mode 100644
index 485a0d8741..0000000000
--- a/otherlibs/labltk/jpf/shell.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-open Unix
-
-(************************************************************* Subshell call *)
-
-let subshell cmd =
- let r,w = pipe () in
- match fork () with
- 0 -> close r; dup2 w stdout;
- close stderr;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127
- | id ->
- close w;
- let rc = in_channel_of_descr r in
- let rec it () = try
- let x = input_line rc in x:: it ()
- with _ -> []
- in
- let answer = it() in
- close_in rc; (* because of finalize_channel *)
- let p, st = waitpid [] id in answer
-
diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli
deleted file mode 100644
index be93f5f1a9..0000000000
--- a/otherlibs/labltk/jpf/shell.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(***********************************************************************)
-(* *)
-(* MLTk, Tcl/Tk interface of Objective Caml *)
-(* *)
-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
-(* projet Cristal, INRIA Rocquencourt *)
-(* Jacques Garrigue, Kyoto University RIMS *)
-(* *)
-(* Copyright 2002 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, with the special exception on linking *)
-(* described in file LICENSE found in the Objective Caml source tree. *)
-(* *)
-(***********************************************************************)
-val subshell : string -> string list
-
View Lorry Controller Status