← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to otherlibs/labltk/jpf/fileselect.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
otherlibs/labltk/jpf/fileselect.ml
14
14
(*                                                                     *)
15
15
(***********************************************************************)
16
16
 
17
 
(* $Id: fileselect.ml 6757 2005-01-28 16:13:11Z doligez $ *)
 
17
(* $Id: fileselect.ml 9547 2010-01-22 12:48:24Z doligez $ *)
18
18
 
19
19
(* file selection box *)
20
20
 
43
43
  Scrollbar.configure sb ~command: (Listbox.yview lb)
44
44
 
45
45
(* focus when enter binding *)
46
 
let bind_enter_focus w = 
 
46
let bind_enter_focus w =
47
47
  bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);;
48
48
 
49
49
let myentry_create p ~variable =
52
52
 
53
53
(************************************************************* Subshell call *)
54
54
 
55
 
let subshell cmd = 
 
55
let subshell cmd =
56
56
  let r,w = pipe () in
57
57
    match fork () with
58
 
      0 -> close r; dup2 ~src:w ~dst:stdout; 
 
58
      0 -> close r; dup2 ~src:w ~dst:stdout;
59
59
           execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]
60
 
    | id -> 
61
 
        close w; 
 
60
    | id ->
 
61
        close w;
62
62
        let rc = in_channel_of_descr r in
63
63
        let rec it l =
64
64
          match
66
66
          with
67
67
            Some x -> it (x::l)
68
68
          | None -> List.rev l
69
 
        in 
 
69
        in
70
70
        let answer = it [] in
71
71
        close_in rc;  (* because of finalize_channel *)
72
72
        let _ = waitpid ~mode:[] id in answer
76
76
(* find directory name which doesn't contain "?*[" *)
77
77
let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)"
78
78
 
79
 
let parse_filter src = 
 
79
let parse_filter src =
80
80
  (* replace // by / *)
81
81
  let s = global_replace (regexp "/+") "/" src in
82
82
  (* replace /./ by / *)
83
83
  let s = global_replace (regexp "/\\./") "/" s in
84
84
  (* replace ????/../ by "" *)
85
85
  let s = global_replace
86
 
      (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") 
 
86
      (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./")
87
87
      ""
88
88
      s in
89
89
  (* replace ????/..$ by "" *)
90
90
  let s = global_replace
91
 
      (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") 
 
91
      (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$")
92
92
      ""
93
93
      s in
94
94
  (* replace ^/../../ by / *)
95
95
  let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in
96
 
  if string_match dirget s 0 then 
 
96
  if string_match dirget s 0 then
97
97
    let dirs = matched_group 1 s
98
98
    and ptrn = matched_group 2 s
99
99
    in
100
100
      dirs, ptrn
101
101
  else "", s
102
 
 
 
102
 
103
103
let ls dir pattern =
104
104
  subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null")
105
105
 
106
106
(*************************************************************** File System *)
107
107
 
108
 
let get_files_in_directory dir = 
 
108
let get_files_in_directory dir =
109
109
  let dirh = opendir dir in
110
110
  let rec get_them l =
111
111
    match
117
117
        get_them (x::l)
118
118
  in
119
119
  List.sort ~cmp:compare (get_them [])
120
 
      
 
120
 
121
121
let rec get_directories_in_files path =
122
122
  List.filter
123
123
    ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
124
124
 
125
 
let remove_directories path = 
 
125
let remove_directories path =
126
126
  List.filter
127
127
    ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
128
128
 
184
184
 
185
185
  let current_pattern = ref ""
186
186
  and current_dir = ref "" in
187
 
  
 
187
 
188
188
  (* init_completions *)
189
189
  let filter_init_completion = ref (fun _ -> ())
190
190
  and directory_init_completion = ref (fun _ -> ()) in
191
 
  
 
191
 
192
192
  let tl = Toplevel.create default_toplevel in
193
193
  Focus.set tl;
194
194
  Wm.title_set tl title;
206
206
        let dflf = Frame.create dfl in
207
207
          let directory_listbox = Listbox.create dflf ~relief: `Sunken
208
208
          and directory_scrollbar = Scrollbar.create dflf in
209
 
            scroll_link directory_scrollbar directory_listbox; 
 
209
            scroll_link directory_scrollbar directory_listbox;
210
210
      let dfr = Frame.create df in
211
211
        let dfrl = Label.create dfr ~text: "Files" in
212
212
        let dfrf = Frame.create dfr in
227
227
(* Printf.eprintf "CURDIR %s\n" curdir; *)
228
228
    let filter =
229
229
      if string_match (regexp "^/.*") filter 0 then filter
230
 
      else 
 
230
      else
231
231
        if filter = "" then !global_dir ^ "/*"
232
232
        else !global_dir ^ "/" ^ filter in
233
233
(* Printf.eprintf "FILTER %s\n" filter; *)
241
241
(* Printf.eprintf "FILTER : %s\n\n" filter; *)
242
242
(* flush Pervasives.stderr; *)
243
243
    try
244
 
      let directories = get_directories_in_files dirname 
 
244
      let directories = get_directories_in_files dirname
245
245
            (get_files_in_directory dirname) in
246
246
      (* get matched file by subshell call. *)
247
 
      let matched_files = remove_directories dirname (ls dirname patternname) 
 
247
      let matched_files = remove_directories dirname (ls dirname patternname)
248
248
      in
249
249
        Textvariable.set filter_var filter;
250
 
        Textvariable.set selection_var (dirname ^ deffile); 
 
250
        Textvariable.set selection_var (dirname ^ deffile);
251
251
        Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End;
252
252
        Listbox.insert directory_listbox ~index:`End ~texts:directories;
253
253
        Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End;
255
255
        !directory_init_completion directory_listbox;
256
256
        !filter_init_completion filter_listbox
257
257
    with
258
 
      Unix_error (ENOENT,_,_) -> 
 
258
      Unix_error (ENOENT,_,_) ->
259
259
        (* Directory is not found (maybe) *)
260
260
        Bell.ring ()
261
261
  in
262
 
  
 
262
 
263
263
  let selected_files = ref [] in (* used for synchronous mode *)
264
264
  let activate l () =
265
265
    Grab.release tl;
266
266
    destroy tl;
267
 
    if sync then 
 
267
    if sync then
268
268
      begin
269
269
        selected_files := l;
270
270
        Textvariable.set sync_var "1"
271
271
      end
272
 
    else 
 
272
    else
273
273
      begin
274
 
        proc l; 
 
274
        proc l;
275
275
        break ()
276
 
      end 
 
276
      end
277
277
  in
278
 
  
 
278
 
279
279
  (* and buttons *)
280
280
    let okb = Button.create cfrm ~text: "OK" ~command:
281
 
      begin fun () -> 
282
 
        let files = 
283
 
          List.map (Listbox.curselection filter_listbox) 
 
281
      begin fun () ->
 
282
        let files =
 
283
          List.map (Listbox.curselection filter_listbox)
284
284
            ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
285
285
        in
286
 
        let files = if files = [] then [Textvariable.get selection_var] 
 
286
        let files = if files = [] then [Textvariable.get selection_var]
287
287
                                  else files in
288
288
        activate files ()
289
289
      end
295
295
 
296
296
  (* binding *)
297
297
  bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true
298
 
    ~action:(fun _ -> activate [Textvariable.get selection_var] ()); 
 
298
    ~action:(fun _ -> activate [Textvariable.get selection_var] ());
299
299
  bind filter_entry ~events:[`KeyPressDetail "Return"]
300
300
      ~action:(fun _ -> configure (Textvariable.get filter_var));
301
 
  
302
 
  let action _ = 
303
 
      let files = 
 
301
 
 
302
  let action _ =
 
303
      let files =
304
304
        List.map (Listbox.curselection filter_listbox)
305
 
          ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) 
 
305
          ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x))
306
306
      in
307
 
        activate files () 
 
307
        activate files ()
308
308
  in
309
 
  bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] 
 
309
  bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
310
310
    ~breakable:true ~action;
311
311
  if multi then Listbox.configure filter_listbox ~selectmode: `Multiple;
312
312
  filter_init_completion := add_completion filter_listbox action;
317
317
          [x] -> Listbox.get directory_listbox ~index:x
318
318
        | _ -> (* you must choose at least one directory. *)
319
319
            Bell.ring (); raise Not_selected)
320
 
       (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) 
 
320
       (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern)
321
321
    with _ -> () in
322
322
  bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)]
323
323
    ~breakable:true ~action;
334
334
    pack [dfl] ~side: `Left;
335
335
    pack [dfll] ~side: `Top ~anchor: `W;
336
336
    pack [dflf] ~side: `Top;
337
 
    pack [coe directory_listbox; coe directory_scrollbar] 
 
337
    pack [coe directory_listbox; coe directory_scrollbar]
338
338
                                          ~side: `Left ~fill: `Y;
339
339
    (* files *)
340
340
    pack [dfr] ~side: `Right;
341
341
    pack [dfrl] ~side: `Top ~anchor: `W;
342
342
    pack [dfrf] ~side: `Top;
343
 
    pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; 
 
343
    pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y;
344
344
    (* selection *)
345
345
    pack [sl] ~side: `Top ~anchor: `W;
346
346
    pack [selection_entry] ~side: `Top ~fill: `X;