(***********************************************************************)

(*                                                                     *)

(*                 MLTk, Tcl/Tk interface of OCaml                     *)

(*                                                                     *)

(*    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 OCaml 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 w stdout;

           execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]

    | 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 _ = 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;

    ()