356 lines
12 KiB
OCaml
356 lines
12 KiB
OCaml
(* $Id$ *)
|
|
|
|
(* file selection box *)
|
|
|
|
open Unix
|
|
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: (`Set ([], 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 name:"/bin/sh" args:[| "/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 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 pat:(regexp "/+") with:"/" src in
|
|
(* replace /./ by / *)
|
|
let s = global_replace pat:(regexp "/\./") with:"/" s in
|
|
(* replace ????/../ by "" *)
|
|
let s = global_replace s
|
|
pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./")
|
|
with:"" in
|
|
(* replace ????/..$ by "" *)
|
|
let s = global_replace s
|
|
pat:(regexp "\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$")
|
|
with:"" in
|
|
(* replace ^/../../ by / *)
|
|
let s = global_replace pat:(regexp "^\(/\.\.\)+/") with:"/" s in
|
|
if string_match pat:dirget s pos: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 () =
|
|
try
|
|
let x = readdir dirh in (* no let cause Out of memory *)
|
|
x::(get_them ())
|
|
with
|
|
End_of_file -> closedir dirh; []
|
|
in
|
|
Sort.list order:(<) (get_them ())
|
|
|
|
let rec get_directories_in_files path = function
|
|
[] -> []
|
|
| x::xs ->
|
|
if try (stat (path ^ x)).st_kind = S_DIR with _ -> false then
|
|
x::(get_directories_in_files path xs)
|
|
else get_directories_in_files path xs
|
|
|
|
let remove_directories dirname =
|
|
let rec remove = function
|
|
[] -> []
|
|
| x :: xs ->
|
|
if try (stat (dirname ^ x)).st_kind = S_DIR with _ -> true then
|
|
remove xs
|
|
else
|
|
x :: (remove xs)
|
|
in remove
|
|
|
|
(************************* 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]
|
|
action: (`Set([`Char; `Time],
|
|
(function ev ->
|
|
(* consider only keys producing characters. The callback is called
|
|
* even if you press Shift.
|
|
*)
|
|
if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char)));
|
|
(* Key specific bindings override KeyPress *)
|
|
bind lb events:[[], `KeyPressDetail "Return"] action:(`Set([], 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: (`Pix 1) relief: `Raised in
|
|
let frm = Frame.create frm' borderwidth: (`Pix 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: (`Pix 1) relief: `Raised in
|
|
let cfrm = Frame.create cfrm' borderwidth: (`Pix 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 pat:(regexp "^/.*") filter pos: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 to:filter;
|
|
Textvariable.set selection_var to:(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 to:"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)
|
|
fun:(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"]
|
|
action:(`Setbreakable ([], fun _ ->
|
|
activate [Textvariable.get selection_var] () ));
|
|
bind filter_entry events:[[], `KeyPressDetail "Return"] action:(`Set ([],
|
|
fun _ -> configure (Textvariable.get filter_var) ));
|
|
|
|
let action _ =
|
|
let files =
|
|
List.map (Listbox.curselection filter_listbox)
|
|
fun:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
|
|
in
|
|
activate files ()
|
|
in
|
|
bind filter_listbox events:[[`Double], `ButtonPressDetail 1]
|
|
action:(`Setbreakable ([], 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:[[`Double], `ButtonPressDetail 1]
|
|
action:(`Setbreakable ([], 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: (`Pix 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;
|
|
()
|