ocaml/otherlibs/labltk/browser/fileselect.ml

(*************************************************************************)
(*                                                                       *)
(*                Objective Caml LablTk library                          *)
(*                                                                       *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 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$ *)

(* file selection box *)

open Useunix
open Str
open Filename

open Tk

(**** Memoized rexgexp *)

let (~) = Jg_memo.fast fun:Str.regexp

(************************************************************ Path name *)

let parse_filter src = 
  (* replace // by / *)
  let s = global_replace pat:~"/+" with:"/" src in
  (* replace /./ by / *)
  let s = global_replace pat:~"/\./" with:"/" s in
  (* replace hoge/../ by "" *)
  let s = global_replace s
      pat:~"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\./" with:"" in
  (* replace hoge/..$ by *)
  let s = global_replace s
      pat:~"\([^/]\|[^\./][^/]\|[^/][^\./]\|[^/][^/]+\)/\.\.$" with:"" in
  (* replace ^/../../ by / *)
  let s = global_replace pat:~"^\(/\.\.\)+/" with:"/" s in
  if string_match s pat:~"^\([^\*?[]*/\)\(.*\)" pos:0 then 
    let dirs = matched_group 1 s
    and ptrn = matched_group 2 s
    in
      dirs, ptrn
  else "", s

let rec fixpoint fun:f v =
  let v' = f v in
  if v = v' then v else fixpoint fun:f v'

let unix_regexp s =
  let s = Str.global_replace pat:~"[$^.+]" with:"\\\\\\0" s in
  let s = Str.global_replace pat:~"\\*" with:".*" s in
  let s = Str.global_replace pat:~"\\?" with:".?" s in
  let s =
    fixpoint s
      fun:(Str.replace_first pat:~"\\({.*\\),\\(.*}\\)" with:"\\1\\|\\2") in
  let s =
    Str.global_replace pat:~"{\\(.*\\)}" with:"\\(\\1\\)" s in
  Str.regexp s

let exact_match s :pat =
  Str.string_match :pat s pos:0 & Str.match_end () = String.length s

let ls :dir :pattern =
  let files = get_files_in_directory dir in
  let regexp = unix_regexp pattern in
  List.filter files pred:(exact_match pat:regexp)

(*
let ls :dir :pattern =
  subshell cmd:("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
*)
 
(********************************************* Creation *)
let load_in_path = ref false

let search_in_path :name = Misc.find_in_path !Config.load_path name

let f :title action:proc ?(:dir = Unix.getcwd ())
    ?(filter:deffilter ="*") ?(file:deffile ="")
    ?(:multi=false) ?(:sync=false) ?(:usepath=true) () =

  let current_pattern = ref ""
  and current_dir = ref dir in
  
  let tl = Jg_toplevel.titled title in
  Focus.set tl;

  let new_var () = Textvariable.create on:tl () in
  let filter_var = new_var ()
  and selection_var = new_var ()
  and sync_var = new_var () in
  Textvariable.set filter_var to:deffilter;

  let frm = Frame.create tl borderwidth:1 relief:`Raised in
    let df = Frame.create frm in
      let dfl = Frame.create df in
        let dfll = Label.create dfl text:"Directories" in
        let dflf, directory_listbox, directory_scrollbar =
            Jg_box.create_with_scrollbar dfl in
      let dfr = Frame.create df in
        let dfrl = Label.create dfr text:"Files" in
        let dfrf, filter_listbox, filter_scrollbar =
            Jg_box.create_with_scrollbar dfr in
  let cfrm = Frame.create tl borderwidth:1 relief:`Raised in

  let configure :filter =
    let filter =
      if string_match pat:~"^/.*" filter pos:0
      then filter
      else !current_dir ^ "/" ^ filter
    in
    let dir, pattern = parse_filter filter in
    let dir = if !load_in_path & usepath then "" else
              (current_dir := Filename.dirname dir; dir)
    and pattern = if pattern = "" then "*" else pattern in
      current_pattern := pattern;
    let filter =
        if !load_in_path & usepath then pattern else dir ^ pattern in
    let directories = get_directories_in_files path:dir 
          (get_files_in_directory dir) in
    let matched_files = (* get matched file by subshell call. *)
      if !load_in_path & usepath then
      List.fold_left !Config.load_path acc:[] fun:
      begin fun :acc dir ->
        let files = ls :dir :pattern in
        Sort.merge order:(<) files
          (List.fold_left files :acc
           fun:(fun :acc name -> List2.exclude item:name acc))
      end
      else
        List.fold_left directories acc:(ls :dir :pattern)
          fun:(fun :acc dir -> List2.exclude item:dir acc)
    in
      Textvariable.set filter_var to:filter;
      Textvariable.set selection_var to:(dir ^ deffile); 
      Listbox.delete filter_listbox first:(`Num 0) last:`End;
      Listbox.insert filter_listbox index:`End texts:matched_files;
      Jg_box.recenter filter_listbox index:(`Num 0);
      if !load_in_path & usepath then
        Listbox.configure directory_listbox takefocus:false
      else
      begin
        Listbox.configure directory_listbox takefocus:true;
        Listbox.delete directory_listbox first:(`Num 0) last:`End;
        Listbox.insert directory_listbox index:`End texts:directories;
        Jg_box.recenter directory_listbox index:(`Num 0)
      end
  in
  
  let selected_files = ref [] in (* used for synchronous mode *)
  let activate l =
    Grab.release tl;
    destroy tl;
    let l =
      if !load_in_path & usepath then
        List.fold_right l acc:[] fun:
        begin fun name :acc ->
          if name <> "" & name.[0] = '/' then name :: acc else
          try search_in_path :name :: acc with Not_found -> acc
        end
      else
        List.map l fun:
        begin fun x ->
          if x <> "" & x.[0] = '/' then x
          else !current_dir ^ "/" ^ x
        end
    in
    if sync then 
      begin
        selected_files := l;
        Textvariable.set sync_var to:"1"
      end
    else proc l 
  in
  
  (* entries *)
  let fl = Label.create frm text:"Filter" in
  let sl = Label.create frm text:"Selection" in
  let filter_entry = Jg_entry.create frm textvariable:filter_var
      command:(fun filter -> configure :filter) in
  let selection_entry = Jg_entry.create frm textvariable:selection_var
      command:(fun file -> activate [file]) in

  (* and buttons *)
  let set_path = Button.create dfl text:"Path editor" command:
    begin fun () ->
      Setpath.add_update_hook (fun () -> configure filter:!current_pattern);
      let w = Setpath.f dir:!current_dir in
      Grab.set w;
      bind w events:[`Destroy] extend:true action:(fun _ -> Grab.set tl)
    end in
  let toggle_in_path = Checkbutton.create dfl text:"Use load path"
    command:
    begin fun () ->
      load_in_path := not !load_in_path;
      if !load_in_path then
        pack [set_path] side:`Bottom fill:`X expand:true
      else
        Pack.forget [set_path];
      configure filter:(Textvariable.get filter_var)
    end
  and okb = Button.create cfrm text:"Ok" command:
    begin fun () -> 
      let files = 
        List.map (Listbox.curselection filter_listbox) fun:
        begin fun x ->
          !current_dir ^ Listbox.get filter_listbox index:x
        end
      in
      let files = if files = [] then [Textvariable.get selection_var] 
                                else files in
      activate [Textvariable.get selection_var]
    end
  and flb = Button.create cfrm text:"Filter"
      command:(fun () -> configure filter:(Textvariable.get filter_var))
  and ccb = Button.create cfrm text:"Cancel"
      command:(fun () -> activate []) in

  (* binding *)
  bind tl events:[`KeyPressDetail "Escape"] action:(fun _ -> activate []);
  Jg_box.add_completion filter_listbox
    action:(fun index -> activate [Listbox.get filter_listbox :index]);
  if multi then Listbox.configure filter_listbox selectmode:`Multiple else
  bind filter_listbox events:[`ButtonPressDetail 1] fields:[`MouseY]
    action:(fun ev ->
      let name = Listbox.get filter_listbox
          index:(Listbox.nearest filter_listbox y:ev.ev_MouseY) in
      if !load_in_path & usepath then
        try Textvariable.set selection_var to:(search_in_path :name)
        with Not_found -> ()
      else Textvariable.set selection_var to:(!current_dir ^ "/" ^ name));

  Jg_box.add_completion directory_listbox action:
    begin fun index ->
      let filter =
        !current_dir ^ "/" ^
        (Listbox.get directory_listbox :index) ^
        "/" ^ !current_pattern
      in configure :filter
    end;

    pack [frm] fill:`Both expand:true;
    (* filter *)
    pack [fl] side:`Top anchor:`W;
    pack [filter_entry] side:`Top fill:`X;

    (* directory + files *)
    pack [df] side:`Top fill:`Both expand:true;
    (* directory *)
    pack [dfl] side:`Left fill:`Both expand:true;
    pack [dfll] side:`Top anchor:`W;
    if usepath then pack [toggle_in_path] side:`Bottom anchor:`W;
    pack [dflf] side:`Top fill:`Both expand:true;
    pack [directory_scrollbar] side:`Right fill:`Y;
    pack [directory_listbox] side:`Left fill:`Both expand:true;
    (* files *)
    pack [dfr] side:`Right fill:`Both expand:true;
    pack [dfrl] side:`Top anchor:`W;
    pack [dfrf] side:`Top fill:`Both expand:true;
    pack [filter_scrollbar] side:`Right fill:`Y; 
    pack [filter_listbox] side:`Left fill:`Both expand:true;

    (* selection *)
    pack [sl] before:df side:`Bottom anchor:`W;
    pack [selection_entry] before:sl side:`Bottom fill:`X;

    (* create OK, Filter and Cancel buttons *)
    pack [okb; flb; ccb] side:`Left fill:`X expand:true;
    pack [cfrm] before:frm side:`Bottom fill:`X;

  if !load_in_path & usepath then begin
    load_in_path := false;
    Checkbutton.invoke toggle_in_path;
    Checkbutton.select toggle_in_path
  end
  else configure filter:deffilter;

    Tkwait.visibility tl;
    Grab.set tl;

    if sync then
      begin
        Tkwait.variable sync_var;
        proc !selected_files
      end;
    ()