462
|
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
|
502
|
41 (globally-declare-fboundp
|
|
42 '(gtk-clist-clear
|
|
43 gtk-clist-freeze gtk-clist-append
|
|
44 gtk-clist-thaw gtk-combo-set-popdown-strings gtk-dialog-new
|
|
45 gtk-dialog-vbox gtk-dialog-action-area gtk-window-set-title
|
|
46 gtk-button-new-with-label gtk-container-add gtk-signal-connect
|
|
47 gtk-entry-get-text gtk-widget-destroy gtk-combo-new
|
|
48 gtk-combo-disable-activate gtk-box-pack-start gtk-combo-entry
|
|
49 gtk-hbox-new gtk-clist-new-with-titles gtk-scrolled-window-new
|
|
50 gtk-widget-set-usize gtk-clist-get-text gtk-entry-set-text
|
|
51 gtk-button-clicked gtk-option-menu-new gtk-menu-new
|
|
52 gtk-label-new gtk-menu-item-new-with-label gtk-menu-append
|
|
53 gtk-widget-show gtk-option-menu-set-menu gtk-box-pack-end
|
|
54 gtk-entry-new gtk-widget-set-sensitive gtk-widget-realize))
|
|
55
|
462
|
56 (defun gtk-file-dialog-fill-file-list (dialog dir)
|
|
57 (if (not dir)
|
|
58 (setq dir (get dialog 'x-file-dialog-current-dir nil)))
|
|
59
|
|
60 (put dialog 'x-file-dialog-current-dir dir)
|
|
61
|
|
62 (let ((list (get dialog 'x-file-dialog-files-list nil))
|
502
|
63 ;(remotep (file-remote-p dir))
|
|
64 )
|
462
|
65 (if (not list)
|
|
66 nil
|
|
67 (gtk-clist-clear list)
|
|
68 (gtk-clist-freeze list)
|
|
69 ;; NOTE: Current versions of efs / ange-ftp do not honor the
|
|
70 ;; files-only flag to directory-files, but actually DOING these
|
|
71 ;; checks is hideously expensive. Leave it turned off for now.
|
502
|
72 (mapc #'(lambda (f)
|
|
73 (if (or t ; Lets just wait for EFS to
|
|
74 ;(not remotep) ; fix itself, shall we?
|
|
75 ;(not (file-directory-p (expand-file-name f dir)))
|
|
76 )
|
|
77 (gtk-clist-append list (list f))))
|
462
|
78 (directory-files dir nil
|
|
79 (get dialog 'x-file-dialog-active-filter nil)
|
|
80 nil t))
|
|
81 (gtk-clist-thaw list))))
|
|
82
|
|
83 (defun gtk-file-dialog-fill-directory-list (dialog dir)
|
|
84 (let ((subdirs (directory-files dir nil nil nil 5))
|
502
|
85 ;(remotep (file-remote-p dir))
|
|
86 ;(selected-dir (get dialog 'x-file-dialog-current-dir "/"))
|
462
|
87 (directory-list (get dialog 'x-file-dialog-directory-list)))
|
|
88
|
|
89 (gtk-clist-freeze directory-list)
|
|
90 (gtk-clist-clear directory-list)
|
|
91
|
|
92 (while subdirs
|
|
93 (if (equal "." (car subdirs))
|
|
94 nil
|
|
95 ;; NOTE: Current versions of efs / ange-ftp do not honor the
|
|
96 ;; files-only flag to directory-files, but actually DOING these
|
|
97 ;; checks is hideously expensive. Leave it turned off for now.
|
|
98 (if (or t ; Lets just wait for EFS to
|
502
|
99 ;(not remotep) ; fix itself, shall we?
|
|
100 ;(file-directory-p (expand-file-name (car subdirs) dir))
|
|
101 )
|
462
|
102 (gtk-clist-append directory-list (list (car subdirs)))))
|
|
103 (pop subdirs))
|
|
104 (gtk-clist-thaw directory-list)))
|
|
105
|
|
106 (defun gtk-file-dialog-update-dropdown (dialog dir)
|
|
107 (let ((combo-box (get dialog 'x-file-dialog-select-list))
|
|
108 (components (reverse
|
|
109 (delete ""
|
|
110 (split-string dir
|
|
111 (concat "[" (char-to-string directory-sep-char) "]")))))
|
|
112 (entries nil))
|
|
113
|
|
114 (while components
|
|
115 (push (concat "/" (mapconcat 'identity (reverse components)
|
|
116 (char-to-string directory-sep-char)))
|
|
117 entries)
|
|
118 (pop components))
|
|
119 (push (expand-file-name "." "~/") entries)
|
|
120 (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
|
|
121
|
|
122 (defun gtk-file-dialog-select-directory (dialog dir)
|
|
123 (gtk-file-dialog-fill-directory-list dialog dir)
|
|
124 (gtk-file-dialog-fill-file-list dialog dir)
|
|
125 (gtk-file-dialog-update-dropdown dialog dir))
|
|
126
|
|
127 (defun gtk-file-dialog-new (&rest keywords)
|
|
128 "Create a XEmacs file selection dialog.
|
|
129 Optional keyword arguments allowed:
|
|
130
|
|
131 :title The title of the dialog
|
|
132 :initial-directory Initial directory to show
|
|
133 :filter-list List of filter descriptions and filters
|
|
134 :file-must-exist Whether the file must exist or not
|
|
135 :directory Look for a directory instead
|
|
136 :callback Function to call with one arg, the selection
|
|
137 "
|
|
138 (let* ((dialog (gtk-dialog-new))
|
|
139 (vbox (gtk-dialog-vbox dialog))
|
|
140 (dir (plist-get keywords :initial-directory default-directory))
|
|
141 (button-area (gtk-dialog-action-area dialog))
|
502
|
142 ;(initializing-gtk-file-dialog t)
|
462
|
143 (select-box nil)
|
|
144 button hbox)
|
|
145
|
|
146 (put dialog 'type 'dialog)
|
|
147
|
|
148 (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
|
|
149
|
|
150 (setq button (gtk-button-new-with-label "OK"))
|
|
151 (gtk-container-add button-area button)
|
|
152 (gtk-signal-connect button 'clicked
|
|
153 (lambda (button dialog)
|
|
154 (funcall
|
|
155 (get dialog 'x-file-dialog-callback 'ignore)
|
|
156 (gtk-entry-get-text
|
|
157 (get dialog 'x-file-dialog-entry nil)))
|
|
158 (gtk-widget-destroy dialog))
|
|
159 dialog)
|
|
160 (put dialog 'x-file-dialog-ok-button button)
|
|
161
|
|
162 (setq button (gtk-button-new-with-label "Cancel"))
|
|
163 (gtk-container-add button-area button)
|
|
164 (gtk-signal-connect button 'clicked
|
|
165 (lambda (button dialog)
|
|
166 (gtk-widget-destroy dialog)) dialog)
|
|
167
|
|
168 (put dialog 'x-file-dialog-cancel-button button)
|
|
169 (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore))
|
|
170 (put dialog 'x-file-dialog-construct-args keywords)
|
|
171 (put dialog 'x-file-dialog-current-dir dir)
|
|
172
|
|
173 ;; Dropdown list of directories...
|
|
174 (setq select-box (gtk-combo-new))
|
|
175 (gtk-combo-disable-activate select-box)
|
|
176 (gtk-box-pack-start vbox select-box nil nil 5)
|
|
177 (put dialog 'x-file-dialog-select-list select-box)
|
|
178
|
|
179 ;; Hitting return in the entry will change dirs...
|
|
180 (gtk-signal-connect (gtk-combo-entry select-box) 'activate
|
|
181 (lambda (entry dialog)
|
|
182 (gtk-file-dialog-select-directory dialog
|
|
183 (gtk-entry-get-text entry)))
|
|
184 dialog)
|
|
185
|
|
186 ;; Start laying out horizontally...
|
|
187 (setq hbox (gtk-hbox-new nil 0))
|
|
188 (gtk-box-pack-start vbox hbox t t 5)
|
|
189
|
|
190 ;; Directory listing
|
|
191 (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
|
502
|
192 (scrolled (gtk-scrolled-window-new nil nil)))
|
462
|
193 (gtk-container-add scrolled directories)
|
|
194 (gtk-widget-set-usize scrolled 200 300)
|
|
195 (gtk-box-pack-start hbox scrolled t t 0)
|
|
196 (put dialog 'x-file-dialog-directory-list directories)
|
|
197 (put dialog 'x-file-dialog-directory-scrolled scrolled)
|
|
198
|
|
199 (gtk-signal-connect directories 'select-row
|
|
200 (lambda (list row column event dialog)
|
|
201 (let ((dir (expand-file-name
|
|
202 (gtk-clist-get-text
|
|
203 (get dialog 'x-file-dialog-directory-list)
|
|
204 row column)
|
|
205 (get dialog 'x-file-dialog-current-dir))))
|
|
206 (if (and (misc-user-event-p event)
|
|
207 (event-function event))
|
|
208 (gtk-file-dialog-select-directory dialog dir)
|
|
209 (gtk-entry-set-text
|
|
210 (get dialog 'x-file-dialog-entry)
|
|
211 dir))))
|
|
212 dialog)
|
|
213 )
|
|
214
|
|
215 (if (plist-get keywords :directory nil)
|
|
216 ;; Directory listings only do not need the file or filters buttons.
|
|
217 nil
|
|
218 ;; File listing
|
|
219 (let ((list (gtk-clist-new-with-titles 1 '("Files")))
|
|
220 (scrolled (gtk-scrolled-window-new nil nil)))
|
|
221 (gtk-container-add scrolled list)
|
|
222 (gtk-widget-set-usize scrolled 200 300)
|
|
223 (gtk-box-pack-start hbox scrolled t t 0)
|
|
224
|
|
225 (gtk-signal-connect list 'select-row
|
|
226 (lambda (list row column event dialog)
|
|
227 (gtk-entry-set-text
|
|
228 (get dialog 'x-file-dialog-entry nil)
|
|
229 (expand-file-name
|
|
230 (gtk-clist-get-text list row column)
|
|
231 (get dialog 'x-file-dialog-current-dir nil)))
|
|
232 (if (and (misc-user-event-p event)
|
|
233 (event-function event))
|
|
234 ;; Got a double or triple click event...
|
|
235 (gtk-button-clicked
|
|
236 (get dialog 'x-file-dialog-ok-button nil))))
|
|
237 dialog)
|
|
238
|
|
239 (put dialog 'x-file-dialog-files-list list))
|
|
240
|
|
241 ;; Filters
|
|
242 (if (not (plist-get keywords :filter-list nil))
|
|
243 ;; Don't need to bother packing this
|
|
244 nil
|
|
245 (setq hbox (gtk-hbox-new nil 0))
|
|
246 (gtk-box-pack-start vbox hbox nil nil 0)
|
|
247
|
|
248 (let ((label nil)
|
|
249 (options (plist-get keywords :filter-list nil))
|
|
250 (omenu nil)
|
|
251 (menu nil)
|
|
252 (item nil))
|
|
253 (setq omenu (gtk-option-menu-new)
|
|
254 menu (gtk-menu-new)
|
|
255 label (gtk-label-new "Filter: "))
|
|
256
|
|
257 (put dialog 'x-file-dialog-active-filter (cdr (car options)))
|
|
258 (mapc (lambda (o)
|
|
259 (setq item (gtk-menu-item-new-with-label (car o)))
|
|
260 (gtk-signal-connect item 'activate
|
|
261 (lambda (obj data)
|
|
262 (put (car data) 'x-file-dialog-active-filter (cdr data))
|
|
263 (gtk-file-dialog-fill-file-list (car data) nil))
|
|
264 (cons dialog (cdr o)))
|
|
265 (gtk-menu-append menu item)
|
|
266 (gtk-widget-show item)) options)
|
|
267 (gtk-option-menu-set-menu omenu menu)
|
|
268 (gtk-box-pack-end hbox omenu nil nil 0)
|
|
269 (gtk-box-pack-end hbox label nil nil 0))))
|
|
270
|
|
271 ;; Entry
|
|
272 (let ((entry (gtk-entry-new)))
|
|
273 (if (plist-get keywords :directory nil)
|
|
274 nil
|
|
275 (gtk-box-pack-start vbox entry nil nil 0))
|
|
276 (if (plist-get keywords :file-must-exist nil)
|
|
277 (progn
|
|
278 (gtk-widget-set-sensitive (get dialog 'x-file-dialog-ok-button nil) nil)
|
|
279 (gtk-signal-connect entry 'changed
|
|
280 (lambda (entry dialog)
|
|
281 (gtk-widget-set-sensitive
|
|
282 (get dialog 'x-file-dialog-ok-button)
|
|
283 (file-exists-p (gtk-entry-get-text entry))))
|
|
284 dialog)))
|
|
285 (put dialog 'x-file-dialog-entry entry))
|
|
286
|
|
287 (gtk-widget-realize dialog)
|
|
288
|
|
289
|
|
290 ;; Populate the file list if necessary
|
|
291 (gtk-file-dialog-select-directory dialog dir)
|
|
292 dialog))
|
|
293
|
|
294 (provide 'gtk-file-dialog)
|