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 XEmacs.
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)
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.
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.
25 ;;; Synched up with: Not in FSF.
29 ;; The default GTK file selection dialog is not sufficient for our
30 ;; needs. Limitations include:
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
39 ;; This attempts to rectify the situation.
41 (defun gtk-file-dialog-fill-file-list (dialog dir)
43 (setq dir (get dialog 'x-file-dialog-current-dir nil)))
45 (put dialog 'x-file-dialog-current-dir dir)
47 (let ((list (get dialog 'x-file-dialog-files-list nil))
48 (remotep (file-remote-p dir)))
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.
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)
64 (gtk-clist-thaw list))))
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)))
72 (gtk-clist-freeze directory-list)
73 (gtk-clist-clear directory-list)
76 (if (equal "." (car subdirs))
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)))))
86 (gtk-clist-thaw directory-list)))
88 (defun gtk-file-dialog-update-dropdown (dialog dir)
89 (let ((combo-box (get dialog 'x-file-dialog-select-list))
93 (concat "[" (char-to-string directory-sep-char) "]")))))
97 (push (concat "/" (mapconcat 'identity (reverse components)
98 (char-to-string directory-sep-char)))
101 (push (expand-file-name "." "~/") entries)
102 (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
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))
109 (defun gtk-file-dialog-new (&rest keywords)
110 "Create a XEmacs file selection dialog.
111 Optional keyword arguments allowed:
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
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)
128 (put dialog 'type 'dialog)
130 (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
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)
137 (get dialog 'x-file-dialog-callback 'ignore)
139 (get dialog 'x-file-dialog-entry nil)))
140 (gtk-widget-destroy dialog))
142 (put dialog 'x-file-dialog-ok-button button)
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)
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)
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)
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)))
168 ;; Start laying out horizontally...
169 (setq hbox (gtk-hbox-new nil 0))
170 (gtk-box-pack-start vbox hbox t t 5)
173 (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
174 (scrolled (gtk-scrolled-window-new nil 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)
182 (gtk-signal-connect directories 'select-row
183 (lambda (list row column event dialog)
184 (let ((dir (expand-file-name
186 (get dialog 'x-file-dialog-directory-list)
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)
193 (get dialog 'x-file-dialog-entry)
198 (if (plist-get keywords :directory nil)
199 ;; Directory listings only do not need the file or filters buttons.
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)
208 (gtk-signal-connect list 'select-row
209 (lambda (list row column event dialog)
211 (get dialog 'x-file-dialog-entry nil)
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...
219 (get dialog 'x-file-dialog-ok-button nil))))
222 (put dialog 'x-file-dialog-files-list list))
225 (if (not (plist-get keywords :filter-list nil))
226 ;; Don't need to bother packing this
228 (setq hbox (gtk-hbox-new nil 0))
229 (gtk-box-pack-start vbox hbox nil nil 0)
232 (options (plist-get keywords :filter-list nil))
236 (setq omenu (gtk-option-menu-new)
238 label (gtk-label-new "Filter: "))
240 (put dialog 'x-file-dialog-active-filter (cdr (car options)))
242 (setq item (gtk-menu-item-new-with-label (car o)))
243 (gtk-signal-connect item 'activate
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))))
255 (let ((entry (gtk-entry-new)))
256 (if (plist-get keywords :directory nil)
258 (gtk-box-pack-start vbox entry nil nil 0))
259 (if (plist-get keywords :file-must-exist nil)
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))))
268 (put dialog 'x-file-dialog-entry entry))
270 (gtk-widget-realize dialog)
273 ;; Populate the file list if necessary
274 (gtk-file-dialog-select-directory dialog dir)
277 (provide 'gtk-file-dialog)