1 ;;; gtk-file-dialog.el --- A nicer file selection dialog for XEmacs w/GTK primitives
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
6 ;; Keywords: extensions, internal
8 ;; This file is part of SXEmacs.
10 ;; SXEmacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; SXEmacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Synched up with: Not in FSF.
27 ;; The default GTK file selection dialog is not sufficient for our
28 ;; needs. Limitations include:
30 ;; - not derived from GtkDialog
31 ;; - no support for filters based on file types
32 ;; - no support for setting an initial directory
33 ;; - no way to tell it 'file must exist'
34 ;; - no easy way to tell it to look at directories only
37 ;; This attempts to rectify the situation.
39 (globally-declare-fboundp
41 gtk-clist-freeze gtk-clist-append
42 gtk-clist-thaw gtk-combo-set-popdown-strings gtk-dialog-new
43 gtk-dialog-vbox gtk-dialog-action-area gtk-window-set-title
44 gtk-button-new-with-label gtk-container-add gtk-signal-connect
45 gtk-entry-get-text gtk-widget-destroy gtk-combo-new
46 gtk-combo-disable-activate gtk-box-pack-start gtk-combo-entry
47 gtk-hbox-new gtk-clist-new-with-titles gtk-scrolled-window-new
48 gtk-widget-set-usize gtk-clist-get-text gtk-entry-set-text
49 gtk-button-clicked gtk-option-menu-new gtk-menu-new
50 gtk-label-new gtk-menu-item-new-with-label gtk-menu-append
51 gtk-widget-show gtk-option-menu-set-menu gtk-box-pack-end
52 gtk-entry-new gtk-widget-set-sensitive gtk-widget-realize))
54 (defun gtk-file-dialog-fill-file-list (dialog dir)
56 (setq dir (get dialog 'x-file-dialog-current-dir nil)))
58 (put dialog 'x-file-dialog-current-dir dir)
60 (let ((list (get dialog 'x-file-dialog-files-list nil))
61 ;(remotep (file-remote-p dir)))
65 (gtk-clist-clear list)
66 (gtk-clist-freeze list)
67 ;; NOTE: Current versions of efs / ange-ftp do not honor the
68 ;; files-only flag to directory-files, but actually DOING these
69 ;; checks is hideously expensive. Leave it turned off for now.
71 (if (or t ; Lets just wait for EFS to
72 ;(not remotep) ; fix itself, shall we?
73 ;(not (file-directory-p (expand-file-name f dir))))
75 (gtk-clist-append list (list f))))
76 (directory-files dir nil
77 (get dialog 'x-file-dialog-active-filter nil)
79 (gtk-clist-thaw list))))
81 (defun gtk-file-dialog-fill-directory-list (dialog dir)
82 (let ((subdirs (directory-files dir nil nil nil 5))
83 ;(remotep (file-remote-p dir))
84 ;(selected-dir (get dialog 'x-file-dialog-current-dir "/"))
85 (directory-list (get dialog 'x-file-dialog-directory-list)))
87 (gtk-clist-freeze directory-list)
88 (gtk-clist-clear directory-list)
91 (if (equal "." (car subdirs))
93 ;; NOTE: Current versions of efs / ange-ftp do not honor the
94 ;; files-only flag to directory-files, but actually DOING these
95 ;; checks is hideously expensive. Leave it turned off for now.
96 (if (or t ; Lets just wait for EFS to
97 ;(not remotep) ; fix itself, shall we?
98 ;(file-directory-p (expand-file-name (car subdirs) dir)))
100 (gtk-clist-append directory-list (list (car subdirs)))))
102 (gtk-clist-thaw directory-list)))
104 (defun gtk-file-dialog-update-dropdown (dialog dir)
105 (let ((combo-box (get dialog 'x-file-dialog-select-list))
109 (concat "[" (char-to-string directory-sep-char) "]")))))
113 (push (concat "/" (mapconcat 'identity (reverse components)
114 (char-to-string directory-sep-char)))
117 (push (expand-file-name "." "~/") entries)
118 (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
120 (defun gtk-file-dialog-select-directory (dialog dir)
121 (gtk-file-dialog-fill-directory-list dialog dir)
122 (gtk-file-dialog-fill-file-list dialog dir)
123 (gtk-file-dialog-update-dropdown dialog dir))
125 (defun gtk-file-dialog-new (&rest keywords)
126 "Create a XEmacs file selection dialog.
127 Optional keyword arguments allowed:
129 :title The title of the dialog
130 :initial-directory Initial directory to show
131 :filter-list List of filter descriptions and filters
132 :file-must-exist Whether the file must exist or not
133 :directory Look for a directory instead
134 :callback Function to call with one arg, the selection
136 (let* ((dialog (gtk-dialog-new))
137 (vbox (gtk-dialog-vbox dialog))
138 (dir (plist-get keywords :initial-directory default-directory))
139 (button-area (gtk-dialog-action-area dialog))
140 ;(initializing-gtk-file-dialog t)
144 (put dialog 'type 'dialog)
146 (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
148 (setq button (gtk-button-new-with-label "OK"))
149 (gtk-container-add button-area button)
150 (gtk-signal-connect button 'clicked
151 (lambda (button dialog)
153 (get dialog 'x-file-dialog-callback 'ignore)
155 (get dialog 'x-file-dialog-entry nil)))
156 (gtk-widget-destroy dialog))
158 (put dialog 'x-file-dialog-ok-button button)
160 (setq button (gtk-button-new-with-label "Cancel"))
161 (gtk-container-add button-area button)
162 (gtk-signal-connect button 'clicked
163 (lambda (button dialog)
164 (gtk-widget-destroy dialog)) dialog)
166 (put dialog 'x-file-dialog-cancel-button button)
167 (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore))
168 (put dialog 'x-file-dialog-construct-args keywords)
169 (put dialog 'x-file-dialog-current-dir dir)
171 ;; Dropdown list of directories...
172 (setq select-box (gtk-combo-new))
173 (gtk-combo-disable-activate select-box)
174 (gtk-box-pack-start vbox select-box nil nil 5)
175 (put dialog 'x-file-dialog-select-list select-box)
177 ;; Hitting return in the entry will change dirs...
178 (gtk-signal-connect (gtk-combo-entry select-box) 'activate
179 (lambda (entry dialog)
180 (gtk-file-dialog-select-directory dialog
181 (gtk-entry-get-text entry)))
184 ;; Start laying out horizontally...
185 (setq hbox (gtk-hbox-new nil 0))
186 (gtk-box-pack-start vbox hbox t t 5)
189 (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
190 (scrolled (gtk-scrolled-window-new nil nil))
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)
199 (gtk-signal-connect directories 'select-row
200 (lambda (list row column event dialog)
201 (let ((dir (expand-file-name
203 (get dialog 'x-file-dialog-directory-list)
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)
210 (get dialog 'x-file-dialog-entry)
215 (if (plist-get keywords :directory nil)
216 ;; Directory listings only do not need the file or filters buttons.
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)
225 (gtk-signal-connect list 'select-row
226 (lambda (list row column event dialog)
228 (get dialog 'x-file-dialog-entry nil)
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...
236 (get dialog 'x-file-dialog-ok-button nil))))
239 (put dialog 'x-file-dialog-files-list list))
242 (if (not (plist-get keywords :filter-list nil))
243 ;; Don't need to bother packing this
245 (setq hbox (gtk-hbox-new nil 0))
246 (gtk-box-pack-start vbox hbox nil nil 0)
249 (options (plist-get keywords :filter-list nil))
253 (setq omenu (gtk-option-menu-new)
255 label (gtk-label-new "Filter: "))
257 (put dialog 'x-file-dialog-active-filter (cdr (car options)))
259 (setq item (gtk-menu-item-new-with-label (car o)))
260 (gtk-signal-connect item 'activate
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))))
272 (let ((entry (gtk-entry-new)))
273 (if (plist-get keywords :directory nil)
275 (gtk-box-pack-start vbox entry nil nil 0))
276 (if (plist-get keywords :file-must-exist nil)
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))))
285 (put dialog 'x-file-dialog-entry entry))
287 (gtk-widget-realize dialog)
290 ;; Populate the file list if necessary
291 (gtk-file-dialog-select-directory dialog dir)
294 (provide 'gtk-file-dialog)