|
Packit |
bd2e5d |
(*************************************************************************)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* OCaml LablTk library *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Jacques Garrigue, Kyoto University RIMS *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Copyright 1999 Institut National de Recherche en Informatique et *)
|
|
Packit |
bd2e5d |
(* en Automatique and Kyoto University. All rights reserved. *)
|
|
Packit |
bd2e5d |
(* This file is distributed under the terms of the GNU Library *)
|
|
Packit |
bd2e5d |
(* General Public License, with the special exception on linking *)
|
|
Packit |
bd2e5d |
(* described in file ../../../LICENSE. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(*************************************************************************)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* $Id$ *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* file selection box *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
open StdLabels
|
|
Packit |
bd2e5d |
open Str
|
|
Packit |
bd2e5d |
open Filename
|
|
Packit |
bd2e5d |
open Tk
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
open Useunix
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(**** Memoized rexgexp *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let (~!) = Jg_memo.fast ~f:Str.regexp
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(************************************************************ Path name *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* Convert Windows-style directory separator '\' to caml-style '/' *)
|
|
Packit |
bd2e5d |
let caml_dir path =
|
|
Packit |
bd2e5d |
if Sys.os_type = "Win32" then
|
|
Packit |
bd2e5d |
global_replace ~!"\\\\" "/" path
|
|
Packit |
bd2e5d |
else path
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let parse_filter s =
|
|
Packit |
bd2e5d |
let s = caml_dir s in
|
|
Packit |
bd2e5d |
(* replace // by / *)
|
|
Packit |
bd2e5d |
let s = global_replace ~!"/+" "/" s in
|
|
Packit |
bd2e5d |
(* replace /./ by / *)
|
|
Packit |
bd2e5d |
let s = global_replace ~!"/\\./" "/" s in
|
|
Packit |
bd2e5d |
(* replace hoge/../ by "" *)
|
|
Packit |
bd2e5d |
let s = global_replace
|
|
Packit |
bd2e5d |
~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in
|
|
Packit |
bd2e5d |
(* replace hoge/..$ by *)
|
|
Packit |
bd2e5d |
let s = global_replace
|
|
Packit |
bd2e5d |
~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in
|
|
Packit |
bd2e5d |
(* replace ^/hoge/../ by / *)
|
|
Packit |
bd2e5d |
let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in
|
|
Packit |
bd2e5d |
if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then
|
|
Packit |
bd2e5d |
let dirs = matched_group 1 s
|
|
Packit |
bd2e5d |
and ptrn = matched_group 2 s
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
dirs, ptrn
|
|
Packit |
bd2e5d |
else "", s
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let rec fixpoint ~f v =
|
|
Packit |
bd2e5d |
let v' = f v in
|
|
Packit |
bd2e5d |
if v = v' then v else fixpoint ~f v'
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let unix_regexp s =
|
|
Packit |
bd2e5d |
let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in
|
|
Packit |
bd2e5d |
let s = Str.global_replace ~!"\\*" ".*" s in
|
|
Packit |
bd2e5d |
let s = Str.global_replace ~!"\\?" ".?" s in
|
|
Packit |
bd2e5d |
let s =
|
|
Packit |
bd2e5d |
fixpoint s
|
|
Packit |
bd2e5d |
~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in
|
|
Packit |
bd2e5d |
let s =
|
|
Packit |
bd2e5d |
Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in
|
|
Packit |
bd2e5d |
Str.regexp s
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let exact_match ~pat s =
|
|
Packit |
bd2e5d |
Str.string_match pat s 0 && Str.match_end () = String.length s
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let ls ~dir ~pattern =
|
|
Packit |
bd2e5d |
let files = get_files_in_directory dir in
|
|
Packit |
bd2e5d |
let regexp = unix_regexp pattern in
|
|
Packit |
bd2e5d |
List.filter files ~f:(exact_match ~pat:regexp)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(********************************************* Creation *)
|
|
Packit |
bd2e5d |
let load_in_path = ref false
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let search_in_path ~name = Misc.find_in_path !Config.load_path name
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let f ~title ~action:proc ?(dir = Unix.getcwd ())
|
|
Packit |
bd2e5d |
?filter:(deffilter ="*") ?file:(deffile ="")
|
|
Packit |
bd2e5d |
?(multi=false) ?(sync=false) ?(usepath=true) () =
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let current_pattern = ref ""
|
|
Packit |
bd2e5d |
and current_dir = ref (caml_dir dir) in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let may_prefix name =
|
|
Packit |
bd2e5d |
if Filename.is_relative name then concat !current_dir name else name in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let tl = Jg_toplevel.titled title in
|
|
Packit |
bd2e5d |
Focus.set tl;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let new_var () = Textvariable.create ~on:tl () in
|
|
Packit |
bd2e5d |
let filter_var = new_var ()
|
|
Packit |
bd2e5d |
and selection_var = new_var ()
|
|
Packit |
bd2e5d |
and sync_var = new_var () in
|
|
Packit |
bd2e5d |
Textvariable.set filter_var deffilter;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
|
|
Packit |
bd2e5d |
let df = Frame.create frm in
|
|
Packit |
bd2e5d |
let dfl = Frame.create df in
|
|
Packit |
bd2e5d |
let dfll = Label.create dfl ~text:"Directories" in
|
|
Packit |
bd2e5d |
let dflf, directory_listbox, directory_scrollbar =
|
|
Packit |
bd2e5d |
Jg_box.create_with_scrollbar dfl in
|
|
Packit |
bd2e5d |
let dfr = Frame.create df in
|
|
Packit |
bd2e5d |
let dfrl = Label.create dfr ~text:"Files" in
|
|
Packit |
bd2e5d |
let dfrf, filter_listbox, filter_scrollbar =
|
|
Packit |
bd2e5d |
Jg_box.create_with_scrollbar dfr in
|
|
Packit |
bd2e5d |
let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let configure ~filter =
|
|
Packit |
bd2e5d |
let filter = may_prefix filter in
|
|
Packit |
bd2e5d |
let dir, pattern = parse_filter filter in
|
|
Packit |
bd2e5d |
let dir = if !load_in_path && usepath then "" else
|
|
Packit |
bd2e5d |
(current_dir := Filename.dirname dir; dir)
|
|
Packit |
bd2e5d |
and pattern = if pattern = "" then "*" else pattern in
|
|
Packit |
bd2e5d |
current_pattern := pattern;
|
|
Packit |
bd2e5d |
let filter =
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then pattern else dir ^ pattern in
|
|
Packit |
bd2e5d |
let directories = get_directories_in_files ~path:dir
|
|
Packit |
bd2e5d |
(get_files_in_directory dir) in
|
|
Packit |
bd2e5d |
let matched_files = (* get matched file by subshell call. *)
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then
|
|
Packit |
bd2e5d |
List.fold_left !Config.load_path ~init:[] ~f:
|
|
Packit |
bd2e5d |
begin fun acc dir ->
|
|
Packit |
bd2e5d |
let files = ls ~dir ~pattern in
|
|
Packit |
bd2e5d |
List.merge compare files
|
|
Packit |
bd2e5d |
(List.fold_left files ~init:acc
|
|
Packit |
bd2e5d |
~f:(fun acc name -> List2.exclude name acc))
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
List.fold_left directories ~init:(ls ~dir ~pattern)
|
|
Packit |
bd2e5d |
~f:(fun acc dir -> List2.exclude dir acc)
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
Textvariable.set filter_var filter;
|
|
Packit |
bd2e5d |
Textvariable.set selection_var (dir ^ deffile);
|
|
Packit |
bd2e5d |
Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
|
|
Packit |
bd2e5d |
Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
|
|
Packit |
bd2e5d |
Jg_box.recenter filter_listbox ~index:(`Num 0);
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then
|
|
Packit |
bd2e5d |
Listbox.configure directory_listbox ~takefocus:false
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
Listbox.configure directory_listbox ~takefocus:true;
|
|
Packit |
bd2e5d |
Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
|
|
Packit |
bd2e5d |
Listbox.insert directory_listbox ~index:`End ~texts:directories;
|
|
Packit |
bd2e5d |
Jg_box.recenter directory_listbox ~index:(`Num 0)
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let selected_files = ref [] in (* used for synchronous mode *)
|
|
Packit |
bd2e5d |
let activate l =
|
|
Packit |
bd2e5d |
Grab.release tl;
|
|
Packit |
bd2e5d |
destroy tl;
|
|
Packit |
bd2e5d |
let l =
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then
|
|
Packit |
bd2e5d |
List.fold_right l ~init:[] ~f:
|
|
Packit |
bd2e5d |
begin fun name acc ->
|
|
Packit |
bd2e5d |
if not (Filename.is_implicit name) then
|
|
Packit |
bd2e5d |
may_prefix name :: acc
|
|
Packit |
bd2e5d |
else try search_in_path ~name :: acc with Not_found -> acc
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
List.map l ~f:may_prefix
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
if sync then
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
selected_files := l;
|
|
Packit |
bd2e5d |
Textvariable.set sync_var "1"
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else proc l
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* entries *)
|
|
Packit |
bd2e5d |
let fl = Label.create frm ~text:"Filter" in
|
|
Packit |
bd2e5d |
let sl = Label.create frm ~text:"Selection" in
|
|
Packit |
bd2e5d |
let filter_entry = Jg_entry.create frm ~textvariable:filter_var
|
|
Packit |
bd2e5d |
~command:(fun filter -> configure ~filter) in
|
|
Packit |
bd2e5d |
let selection_entry = Jg_entry.create frm ~textvariable:selection_var
|
|
Packit |
bd2e5d |
~command:(fun file -> activate [file]) in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* and buttons *)
|
|
Packit |
bd2e5d |
let set_path = Button.create dfl ~text:"Path editor" ~command:
|
|
Packit |
bd2e5d |
begin fun () ->
|
|
Packit |
bd2e5d |
Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern);
|
|
Packit |
bd2e5d |
let w = Setpath.f ~dir:!current_dir in
|
|
Packit |
bd2e5d |
Grab.set w;
|
|
Packit |
bd2e5d |
bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl)
|
|
Packit |
bd2e5d |
end in
|
|
Packit |
bd2e5d |
let toggle_in_path = Checkbutton.create dfl ~text:"Use load path"
|
|
Packit |
bd2e5d |
~command:
|
|
Packit |
bd2e5d |
begin fun () ->
|
|
Packit |
bd2e5d |
load_in_path := not !load_in_path;
|
|
Packit |
bd2e5d |
if !load_in_path then
|
|
Packit |
bd2e5d |
pack [set_path] ~side:`Bottom ~fill:`X ~expand:true
|
|
Packit |
bd2e5d |
else
|
|
Packit |
bd2e5d |
Pack.forget [set_path];
|
|
Packit |
bd2e5d |
configure ~filter:(Textvariable.get filter_var)
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
and okb = Button.create cfrm ~text:"Ok" ~command:
|
|
Packit |
bd2e5d |
begin fun () ->
|
|
Packit |
bd2e5d |
let files =
|
|
Packit |
bd2e5d |
List.map (Listbox.curselection filter_listbox) ~f:
|
|
Packit |
bd2e5d |
begin fun x ->
|
|
Packit |
bd2e5d |
!current_dir ^ Listbox.get filter_listbox ~index:x
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
let files = if files = [] then [Textvariable.get selection_var]
|
|
Packit |
bd2e5d |
else files in
|
|
Packit |
bd2e5d |
activate files
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
and flb = Button.create cfrm ~text:"Filter"
|
|
Packit |
bd2e5d |
~command:(fun () -> configure ~filter:(Textvariable.get filter_var))
|
|
Packit |
bd2e5d |
and ccb = Button.create cfrm ~text:"Cancel"
|
|
Packit |
bd2e5d |
~command:(fun () -> activate []) in
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* binding *)
|
|
Packit |
bd2e5d |
bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []);
|
|
Packit |
bd2e5d |
Jg_box.add_completion filter_listbox
|
|
Packit |
bd2e5d |
~action:(fun index -> activate [Listbox.get filter_listbox ~index]);
|
|
Packit |
bd2e5d |
if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else
|
|
Packit |
bd2e5d |
bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY]
|
|
Packit |
bd2e5d |
~action:(fun ev ->
|
|
Packit |
bd2e5d |
let name = Listbox.get filter_listbox
|
|
Packit |
bd2e5d |
~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then
|
|
Packit |
bd2e5d |
try Textvariable.set selection_var (search_in_path ~name)
|
|
Packit |
bd2e5d |
with Not_found -> ()
|
|
Packit |
bd2e5d |
else Textvariable.set selection_var (may_prefix name));
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
Jg_box.add_completion directory_listbox ~action:
|
|
Packit |
bd2e5d |
begin fun index ->
|
|
Packit |
bd2e5d |
let filter =
|
|
Packit |
bd2e5d |
may_prefix (Listbox.get directory_listbox ~index) ^
|
|
Packit |
bd2e5d |
"/" ^ !current_pattern
|
|
Packit |
bd2e5d |
in configure ~filter
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
pack [frm] ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
(* filter *)
|
|
Packit |
bd2e5d |
pack [fl] ~side:`Top ~anchor:`W;
|
|
Packit |
bd2e5d |
pack [filter_entry] ~side:`Top ~fill:`X;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* directory + files *)
|
|
Packit |
bd2e5d |
pack [df] ~side:`Top ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
(* directory *)
|
|
Packit |
bd2e5d |
pack [dfl] ~side:`Left ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
pack [dfll] ~side:`Top ~anchor:`W;
|
|
Packit |
bd2e5d |
if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W;
|
|
Packit |
bd2e5d |
pack [dflf] ~side:`Top ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
pack [directory_scrollbar] ~side:`Right ~fill:`Y;
|
|
Packit |
bd2e5d |
pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
(* files *)
|
|
Packit |
bd2e5d |
pack [dfr] ~side:`Right ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
pack [dfrl] ~side:`Top ~anchor:`W;
|
|
Packit |
bd2e5d |
pack [dfrf] ~side:`Top ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
pack [filter_scrollbar] ~side:`Right ~fill:`Y;
|
|
Packit |
bd2e5d |
pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* selection *)
|
|
Packit |
bd2e5d |
pack [sl] ~before:df ~side:`Bottom ~anchor:`W;
|
|
Packit |
bd2e5d |
pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* create OK, Filter and Cancel buttons *)
|
|
Packit |
bd2e5d |
pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true;
|
|
Packit |
bd2e5d |
pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if !load_in_path && usepath then begin
|
|
Packit |
bd2e5d |
load_in_path := false;
|
|
Packit |
bd2e5d |
Checkbutton.invoke toggle_in_path;
|
|
Packit |
bd2e5d |
Checkbutton.select toggle_in_path
|
|
Packit |
bd2e5d |
end
|
|
Packit |
bd2e5d |
else configure ~filter:deffilter;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
Tkwait.visibility tl;
|
|
Packit |
bd2e5d |
Grab.set tl;
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
if sync then
|
|
Packit |
bd2e5d |
begin
|
|
Packit |
bd2e5d |
Tkwait.variable sync_var;
|
|
Packit |
bd2e5d |
proc !selected_files
|
|
Packit |
bd2e5d |
end;
|
|
Packit |
bd2e5d |
()
|