l4/pkg/ocaml/contrib/otherlibs/labltk/jpf/fileselect.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16
  17 (* $Id: fileselect.ml 6757 2005-01-28 16:13:11Z doligez $ *)
  18
  19 (* file selection box *)
  20
  21 (* This file selecter works only under the OS with the full unix support.
  22    For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *)
  23
  24 open StdLabels
  25 open UnixLabels
  26 open Str
  27 open Filename
  28
  29 open Tk
  30 open Widget
  31
  32 exception Not_selected
  33
  34 (********************************************************** Search directory *)
  35 (* Default is curdir *)
  36 let global_dir = ref (getcwd ())
  37
  38 (***************************************************** Some widgets creation *)
  39
  40 (* from frx_listbox.ml *)
  41 let scroll_link sb lb =
  42   Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb);
  43   Scrollbar.configure sb ~command: (Listbox.yview lb)
  44
  45 (* focus when enter binding *)
  46 let bind_enter_focus w =
  47   bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);;
  48
  49 let myentry_create p ~variable =
  50   let w = Entry.create p ~relief: `Sunken ~textvariable: variable in
  51   bind_enter_focus w; w
  52
  53 (************************************************************* Subshell call *)
  54
  55 let subshell cmd =
  56   let r,w = pipe () in
  57     match fork () with
  58       0 -> close r; dup2 ~src:w ~dst:stdout;
  59            execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]
  60     | id ->
  61         close w;
  62         let rc = in_channel_of_descr r in
  63         let rec it l =
  64           match
  65             try Some(input_line rc) with _ -> None
  66           with
  67             Some x -> it (x::l)
  68           | None -> List.rev l
  69         in
  70         let answer = it [] in
  71         close_in rc;  (* because of finalize_channel *)
  72         let _ = waitpid ~mode:[] id in answer
  73
  74 (***************************************************************** Path name *)
  75
  76 (* find directory name which doesn't contain "?*[" *)
  77 let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)"
  78
  79 let parse_filter src =
  80   (* replace // by / *)
  81   let s = global_replace (regexp "/+") "/" src in
  82   (* replace /./ by / *)
  83   let s = global_replace (regexp "/\\./") "/" s in
  84   (* replace ????/../ by "" *)
  85   let s = global_replace
  86       (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./")
  87       ""
  88       s in
  89   (* replace ????/..$ by "" *)
  90   let s = global_replace
  91       (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$")
  92       ""
  93       s in
  94   (* replace ^/../../ by / *)
  95   let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in
  96   if string_match dirget s 0 then
  97     let dirs = matched_group 1 s
  98     and ptrn = matched_group 2 s
  99     in
 100       dirs, ptrn
 101   else "", s
 102
 103 let ls dir pattern =
 104   subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
 105
 106 (*************************************************************** File System *)
 107
 108 let get_files_in_directory dir =
 109   let dirh = opendir dir in
 110   let rec get_them l =
 111     match
 112       try Some(Unix.readdir dirh) with _ -> None
 113     with
 114     | None ->
 115         Unix.closedir dirh; l
 116     | Some x ->
 117         get_them (x::l)
 118   in
 119   List.sort ~cmp:compare (get_them [])
 120
 121 let rec get_directories_in_files path =
 122   List.filter
 123     ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
 124
 125 let remove_directories path =
 126   List.filter
 127     ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
 128
 129 (************************* a nice interface to listbox - from frx_listbox.ml *)
 130
 131 let add_completion lb action =
 132   let prefx = ref ""              (* current match prefix *)
 133   and maxi = ref 0                (* maximum index (doesn'y matter actually) *)
 134   and current = ref 0              (* current position *)
 135   and lastevent = ref 0 in
 136
 137   let rec move_forward () =
 138     if Listbox.get lb ~index:(`Num !current) < !prefx then
 139       if !current < !maxi then begin incr current; move_forward() end
 140
 141   and recenter () =
 142     let element = `Num !current in
 143      (* Clean the selection *)
 144      Listbox.selection_clear lb ~first:(`Num 0) ~last:`End;
 145      (* Set it to our unique element *)
 146      Listbox.selection_set lb ~first:element ~last:element;
 147      (* Activate it, to keep consistent with Up/Down.
 148         You have to be in Extended or Browse mode *)
 149      Listbox.activate lb ~index:element;
 150      Listbox.selection_anchor lb ~index:element;
 151      Listbox.see lb ~index:element in
 152
 153   let complete time s =
 154     if time - !lastevent < 500 then   (* sorry, hard coded limit *)
 155       prefx := !prefx ^ s
 156     else begin (* reset *)
 157       current := 0;
 158       prefx := s
 159     end;
 160     lastevent := time;
 161     move_forward();
 162     recenter() in
 163
 164
 165   bind lb ~events:[`KeyPress] ~fields:[`Char; `Time]
 166     (* consider only keys producing characters. The callback is called
 167        if you press Shift. *)
 168     ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char);
 169   (* Key specific bindings override KeyPress *)
 170   bind lb ~events:[`KeyPressDetail "Return"] ~action;
 171   (* Finally, we have to set focus, otherwise events dont get through *)
 172   Focus.set lb;
 173   recenter()   (* so that first item is selected *);
 174   (* returns init_completion function *)
 175   (fun lb ->
 176     prefx := "";
 177     maxi := Listbox.size lb - 1;
 178     current := 0)
 179
 180 (****************************************************************** Creation *)
 181
 182 let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync =
 183   (* Ah ! Now I regret about the names of the widgets... *)
 184
 185   let current_pattern = ref ""
 186   and current_dir = ref "" in
 187
 188   (* init_completions *)
 189   let filter_init_completion = ref (fun _ -> ())
 190   and directory_init_completion = ref (fun _ -> ()) in
 191
 192   let tl = Toplevel.create default_toplevel in
 193   Focus.set tl;
 194   Wm.title_set tl title;
 195
 196   let filter_var = Textvariable.create ~on:tl () (* new_temporary *)
 197   and selection_var = Textvariable.create ~on:tl ()
 198   and sync_var = Textvariable.create ~on:tl () in
 199
 200   let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
 201     let frm = Frame.create frm' ~borderwidth: 8 in
 202     let fl = Label.create  frm ~text: "Filter" in
 203     let df = Frame.create frm in
 204       let dfl = Frame.create df in
 205         let dfll = Label.create dfl ~text: "Directories" in
 206         let dflf = Frame.create dfl in
 207           let directory_listbox = Listbox.create dflf ~relief: `Sunken
 208           and directory_scrollbar = Scrollbar.create dflf in
 209             scroll_link directory_scrollbar directory_listbox;
 210       let dfr = Frame.create df in
 211         let dfrl = Label.create dfr ~text: "Files" in
 212         let dfrf = Frame.create dfr in
 213           let filter_listbox = Listbox.create dfrf ~relief: `Sunken in
 214           let filter_scrollbar = Scrollbar.create dfrf in
 215             scroll_link filter_scrollbar filter_listbox;
 216     let sl = Label.create frm ~text: "Selection" in
 217     let filter_entry = myentry_create frm ~variable: filter_var in
 218     let selection_entry = myentry_create frm ~variable: selection_var
 219     in
 220   let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in
 221     let cfrm = Frame.create cfrm' ~borderwidth: 8 in
 222     let dumf = Frame.create cfrm in
 223     let dumf2 = Frame.create cfrm in
 224
 225   let configure filter =
 226     (* OLDER let curdir = getcwd () in *)
 227 (* Printf.eprintf "CURDIR %s\n" curdir; *)
 228     let filter =
 229       if string_match (regexp "^/.*") filter 0 then filter
 230       else
 231         if filter = "" then !global_dir ^ "/*"
 232         else !global_dir ^ "/" ^ filter in
 233 (* Printf.eprintf "FILTER %s\n" filter; *)
 234     let dirname, patternname = parse_filter filter in
 235 (* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *)
 236       current_dir := dirname;
 237       global_dir := dirname;
 238     let patternname = if patternname = "" then "*" else patternname in
 239       current_pattern := patternname;
 240     let filter = dirname ^ patternname in
 241 (* Printf.eprintf "FILTER : %s\n\n" filter; *)
 242 (* flush Pervasives.stderr; *)
 243     try
 244       let directories = get_directories_in_files dirname
 245             (get_files_in_directory dirname) in
 246       (* get matched file by subshell call. *)
 247       let matched_files = remove_directories dirname (ls dirname patternname)
 248       in
 249         Textvariable.set filter_var filter;
 250         Textvariable.set selection_var (dirname ^ deffile);
 251         Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
 252         Listbox.insert directory_listbox ~index:`End ~texts:directories;
 253         Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
 254         Listbox.insert filter_listbox ~index:`End ~texts:matched_files;
 255         !directory_init_completion directory_listbox;
 256         !filter_init_completion filter_listbox
 257     with
 258       Unix_error (ENOENT,_,_) ->
 259         (* Directory is not found (maybe) *)
 260         Bell.ring ()
 261   in
 262
 263   let selected_files = ref [] in (* used for synchronous mode *)
 264   let activate l () =
 265     Grab.release tl;
 266     destroy tl;
 267     if sync then
 268       begin
 269         selected_files := l;
 270         Textvariable.set sync_var "1"
 271       end
 272     else
 273       begin
 274         proc l;
 275         break ()
 276       end
 277   in
 278
 279   (* and buttons *)
 280     let okb = Button.create cfrm ~text: "OK" ~command:
 281       begin fun () ->
 282         let files =
 283           List.map (Listbox.curselection filter_listbox)
 284             ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
 285         in
 286         let files = if files = [] then [Textvariable.get selection_var]
 287                                   else files in
 288         activate files ()
 289       end
 290     in
 291     let flb = Button.create cfrm ~text: "Filter"
 292       ~command: (fun () -> configure (Textvariable.get filter_var)) in
 293     let ccb = Button.create cfrm ~text: "Cancel"
 294       ~command: (fun () -> activate [] ()) in
 295
 296   (* binding *)
 297   bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true
 298     ~action:(fun _ -> activate [Textvariable.get selection_var] ());
 299   bind filter_entry ~events:[`KeyPressDetail "Return"]
 300       ~action:(fun _ -> configure (Textvariable.get filter_var));
 301
 302   let action _ =
 303       let files =
 304         List.map (Listbox.curselection filter_listbox)
 305           ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
 306       in
 307         activate files ()
 308   in
 309   bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
 310     ~breakable:true ~action;
 311   if multi then Listbox.configure filter_listbox ~selectmode: `Multiple;
 312   filter_init_completion := add_completion filter_listbox action;
 313
 314   let action _ =
 315     try
 316       configure (!current_dir ^ ((function
 317           [x] -> Listbox.get directory_listbox ~index:x
 318         | _ -> (* you must choose at least one directory. *)
 319             Bell.ring (); raise Not_selected)
 320        (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern)
 321     with _ -> () in
 322   bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
 323     ~breakable:true ~action;
 324   Listbox.configure directory_listbox ~selectmode: `Browse;
 325   directory_init_completion := add_completion directory_listbox action;
 326
 327     pack [frm'; frm] ~fill: `X;
 328     (* filter *)
 329     pack [fl] ~side: `Top ~anchor: `W;
 330     pack [filter_entry] ~side: `Top ~fill: `X;
 331     (* directory + files *)
 332     pack [df] ~side: `Top ~fill: `X ~ipadx: 8;
 333     (* directory *)
 334     pack [dfl] ~side: `Left;
 335     pack [dfll] ~side: `Top ~anchor: `W;
 336     pack [dflf] ~side: `Top;
 337     pack [coe directory_listbox; coe directory_scrollbar]
 338                                           ~side: `Left ~fill: `Y;
 339     (* files *)
 340     pack [dfr] ~side: `Right;
 341     pack [dfrl] ~side: `Top ~anchor: `W;
 342     pack [dfrf] ~side: `Top;
 343     pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y;
 344     (* selection *)
 345     pack [sl] ~side: `Top ~anchor: `W;
 346     pack [selection_entry] ~side: `Top ~fill: `X;
 347
 348     (* create OK, Filter and Cancel buttons *)
 349     pack [cfrm'] ~fill: `X;
 350     pack [cfrm] ~fill: `X;
 351     pack [okb] ~side: `Left;
 352     pack [dumf] ~side: `Left ~expand: true;
 353     pack [flb] ~side: `Left;
 354     pack [dumf2] ~side: `Left ~expand: true;
 355     pack [ccb] ~side: `Left;
 356
 357     configure deffilter;
 358
 359     Tkwait.visibility tl;
 360     Grab.set tl;
 361
 362     if sync then
 363       begin
 364         Tkwait.variable sync_var;
 365         proc !selected_files
 366       end;
 367     ()