(U+51A0): Add HNG-GOK0529-0.
[chise/xemacs-chise.git] / lisp / gtk-file-dialog.el
1 ;;; gtk-file-dialog.el --- A nicer file selection dialog for XEmacs w/GTK primitives
2
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
4
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
6 ;; Keywords: extensions, internal
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING.  If not, write to the 
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF.
26
27 ;;; Commentary:
28
29 ;; The default GTK file selection dialog is not sufficient for our
30 ;; needs.  Limitations include:
31 ;;
32 ;; - not derived from GtkDialog
33 ;; - no support for filters based on file types
34 ;; - no support for setting an initial directory
35 ;; - no way to tell it 'file must exist'
36 ;; - no easy way to tell it to look at directories only
37 ;; - ugly as sin
38 ;;
39 ;; This attempts to rectify the situation.
40
41 (defun gtk-file-dialog-fill-file-list (dialog dir)
42   (if (not dir)
43       (setq dir (get dialog 'x-file-dialog-current-dir nil)))
44
45   (put dialog 'x-file-dialog-current-dir dir)
46
47   (let ((list (get dialog 'x-file-dialog-files-list nil))
48         (remotep (file-remote-p dir)))
49     (if (not list)
50         nil
51       (gtk-clist-clear list)
52       (gtk-clist-freeze list)
53       ;; NOTE: Current versions of efs / ange-ftp do not honor the
54       ;; files-only flag to directory-files, but actually DOING these
55       ;; checks is hideously expensive.  Leave it turned off for now.
56       (mapc (lambda (f)
57               (if (or t                 ; Lets just wait for EFS to
58                       (not remotep)     ; fix itself, shall we?
59                       (not (file-directory-p (expand-file-name f dir))))
60                   (gtk-clist-append list (list f))))
61             (directory-files dir nil
62                              (get dialog 'x-file-dialog-active-filter nil)
63                              nil t))
64       (gtk-clist-thaw list))))
65
66 (defun gtk-file-dialog-fill-directory-list (dialog dir)
67   (let ((subdirs (directory-files dir nil nil nil 5))
68         (remotep (file-remote-p dir))
69         (selected-dir (get dialog 'x-file-dialog-current-dir "/"))
70         (directory-list (get dialog 'x-file-dialog-directory-list)))
71
72     (gtk-clist-freeze directory-list)
73     (gtk-clist-clear directory-list)
74
75     (while subdirs
76       (if (equal "." (car subdirs))
77           nil
78         ;; NOTE: Current versions of efs / ange-ftp do not honor the
79         ;; files-only flag to directory-files, but actually DOING these
80         ;; checks is hideously expensive.  Leave it turned off for now.
81         (if (or t                       ; Lets just wait for EFS to
82                 (not remotep)           ; fix itself, shall we?
83                 (file-directory-p (expand-file-name (car subdirs) dir)))
84             (gtk-clist-append directory-list (list (car subdirs)))))
85       (pop subdirs))
86     (gtk-clist-thaw directory-list)))
87
88 (defun gtk-file-dialog-update-dropdown (dialog dir)
89   (let ((combo-box (get dialog 'x-file-dialog-select-list))
90         (components (reverse
91                      (delete ""
92                              (split-string dir
93                                            (concat "[" (char-to-string directory-sep-char) "]")))))
94         (entries nil))
95
96     (while components
97       (push (concat "/" (mapconcat 'identity (reverse components)
98                                    (char-to-string directory-sep-char)))
99             entries)
100       (pop components))
101     (push (expand-file-name "." "~/") entries)
102     (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
103
104 (defun gtk-file-dialog-select-directory (dialog dir)
105   (gtk-file-dialog-fill-directory-list dialog dir)
106   (gtk-file-dialog-fill-file-list dialog dir)
107   (gtk-file-dialog-update-dropdown dialog dir))
108
109 (defun gtk-file-dialog-new (&rest keywords)
110   "Create a XEmacs file selection dialog.
111 Optional keyword arguments allowed:
112
113 :title                  The title of the dialog
114 :initial-directory      Initial directory to show
115 :filter-list            List of filter descriptions and filters
116 :file-must-exist        Whether the file must exist or not
117 :directory              Look for a directory instead
118 :callback               Function to call with one arg, the selection
119 "
120   (let* ((dialog (gtk-dialog-new))
121          (vbox (gtk-dialog-vbox dialog))
122          (dir (plist-get keywords :initial-directory default-directory))
123          (button-area (gtk-dialog-action-area dialog))
124          (initializing-gtk-file-dialog t)
125          (select-box nil)
126          button hbox)
127
128     (put dialog 'type 'dialog)
129
130     (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
131
132     (setq button (gtk-button-new-with-label "OK"))
133     (gtk-container-add button-area button)
134     (gtk-signal-connect button 'clicked
135                         (lambda (button dialog)
136                           (funcall
137                            (get dialog 'x-file-dialog-callback 'ignore)
138                            (gtk-entry-get-text
139                             (get dialog 'x-file-dialog-entry nil)))
140                           (gtk-widget-destroy dialog))
141                         dialog)
142     (put dialog 'x-file-dialog-ok-button button)
143
144     (setq button (gtk-button-new-with-label "Cancel"))
145     (gtk-container-add button-area button)
146     (gtk-signal-connect button 'clicked
147                         (lambda (button dialog)
148                           (gtk-widget-destroy dialog)) dialog)
149
150     (put dialog 'x-file-dialog-cancel-button button)
151     (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore))
152     (put dialog 'x-file-dialog-construct-args keywords)
153     (put dialog 'x-file-dialog-current-dir dir)
154
155     ;; Dropdown list of directories...
156     (setq select-box (gtk-combo-new))
157     (gtk-combo-disable-activate select-box)
158     (gtk-box-pack-start vbox select-box nil nil 5)
159     (put dialog 'x-file-dialog-select-list select-box)
160
161     ;; Hitting return in the entry will change dirs...
162     (gtk-signal-connect (gtk-combo-entry select-box) 'activate
163                         (lambda (entry dialog)
164                           (gtk-file-dialog-select-directory dialog
165                                                             (gtk-entry-get-text entry)))
166                         dialog)
167
168     ;; Start laying out horizontally...
169     (setq hbox (gtk-hbox-new nil 0))
170     (gtk-box-pack-start vbox hbox t t 5)
171
172     ;; Directory listing
173     (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
174           (scrolled (gtk-scrolled-window-new nil nil))
175           (item nil))
176       (gtk-container-add scrolled directories)
177       (gtk-widget-set-usize scrolled 200 300)
178       (gtk-box-pack-start hbox scrolled t t 0)
179       (put dialog 'x-file-dialog-directory-list directories)
180       (put dialog 'x-file-dialog-directory-scrolled scrolled)
181
182       (gtk-signal-connect directories 'select-row
183                           (lambda (list row column event dialog)
184                             (let ((dir (expand-file-name
185                                          (gtk-clist-get-text
186                                           (get dialog 'x-file-dialog-directory-list)
187                                           row column)
188                                          (get dialog 'x-file-dialog-current-dir))))
189                               (if (and (misc-user-event-p event)
190                                        (event-function event))
191                                   (gtk-file-dialog-select-directory dialog dir)
192                                 (gtk-entry-set-text
193                                  (get dialog 'x-file-dialog-entry)
194                                  dir))))
195                           dialog)
196       )
197
198     (if (plist-get keywords :directory nil)
199         ;; Directory listings only do not need the file or filters buttons.
200         nil
201       ;; File listing
202       (let ((list (gtk-clist-new-with-titles 1 '("Files")))
203             (scrolled (gtk-scrolled-window-new nil nil)))
204         (gtk-container-add scrolled list)
205         (gtk-widget-set-usize scrolled 200 300)
206         (gtk-box-pack-start hbox scrolled t t 0)
207
208         (gtk-signal-connect list 'select-row
209                             (lambda (list row column event dialog)
210                               (gtk-entry-set-text
211                                (get dialog 'x-file-dialog-entry nil)
212                                (expand-file-name
213                                 (gtk-clist-get-text list row column)
214                                 (get dialog 'x-file-dialog-current-dir nil)))
215                               (if (and (misc-user-event-p event)
216                                        (event-function event))
217                                   ;; Got a double or triple click event...
218                                   (gtk-button-clicked
219                                    (get dialog 'x-file-dialog-ok-button nil))))
220                             dialog)
221
222         (put dialog 'x-file-dialog-files-list list))
223
224       ;; Filters
225       (if (not (plist-get keywords :filter-list nil))
226           ;; Don't need to bother packing this
227           nil
228         (setq hbox (gtk-hbox-new nil 0))
229         (gtk-box-pack-start vbox hbox nil nil 0)
230
231         (let ((label nil)
232               (options (plist-get keywords :filter-list nil))
233               (omenu nil)
234               (menu nil)
235               (item nil))
236           (setq omenu (gtk-option-menu-new)
237                 menu (gtk-menu-new)
238                 label (gtk-label-new "Filter: "))
239
240           (put dialog 'x-file-dialog-active-filter (cdr (car options)))
241           (mapc (lambda (o)
242                   (setq item (gtk-menu-item-new-with-label (car o)))
243                   (gtk-signal-connect item 'activate
244                                       (lambda (obj data)
245                                         (put (car data) 'x-file-dialog-active-filter (cdr data))
246                                         (gtk-file-dialog-fill-file-list (car data) nil))
247                                       (cons dialog (cdr o)))
248                   (gtk-menu-append menu item)
249                   (gtk-widget-show item)) options)
250           (gtk-option-menu-set-menu omenu menu)
251           (gtk-box-pack-end hbox omenu nil nil 0)
252           (gtk-box-pack-end hbox label nil nil 0))))
253
254       ;; Entry
255     (let ((entry (gtk-entry-new)))
256       (if (plist-get keywords :directory nil)
257           nil
258         (gtk-box-pack-start vbox entry nil nil 0))
259       (if (plist-get keywords :file-must-exist nil)
260           (progn
261             (gtk-widget-set-sensitive (get dialog 'x-file-dialog-ok-button nil) nil)
262             (gtk-signal-connect entry 'changed
263                                 (lambda (entry dialog)
264                                   (gtk-widget-set-sensitive
265                                    (get dialog 'x-file-dialog-ok-button)
266                                    (file-exists-p (gtk-entry-get-text entry))))
267                                 dialog)))
268       (put dialog 'x-file-dialog-entry entry))
269
270     (gtk-widget-realize dialog)
271
272
273     ;; Populate the file list if necessary
274     (gtk-file-dialog-select-directory dialog dir)
275     dialog))
276
277 (provide 'gtk-file-dialog)