Mercurial > hg > xemacs-beta
comparison lisp/gtk-file-dialog.el @ 462:0784d089fdc9 r21-2-46
Import from CVS: tag r21-2-46
author | cvs |
---|---|
date | Mon, 13 Aug 2007 11:44:37 +0200 |
parents | |
children | 7039e6323819 |
comparison
equal
deleted
inserted
replaced
461:120ed4009e51 | 462:0784d089fdc9 |
---|---|
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) |