Mercurial > hg > xemacs-beta
annotate lisp/gtk-file-dialog.el @ 5889:bd644055ef44
Correct a bug in #'check-type, non-setf'able PLACEs
lisp/ChangeLog addition:
2015-04-11 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el:
* cl-macs.el (check-type):
Correct the sense of the type test here when PLACE is not
setf'able, something which gave confusing errors with literal
fixnums or, e.g., (+ 30 40).
tests/ChangeLog addition:
2015-04-11 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Check for a bug just fixed in cl-macs.el.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 11 Apr 2015 18:06:17 +0100 |
| parents | bbe4146603db |
| children |
| rev | line source |
|---|---|
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
13 ;; option) any later version. |
| 462 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
18 ;; for more details. |
| 462 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
502
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 462 | 22 |
| 23 ;;; Synched up with: Not in FSF. | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;; The default GTK file selection dialog is not sufficient for our | |
| 28 ;; needs. Limitations include: | |
| 29 ;; | |
| 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 | |
| 35 ;; - ugly as sin | |
| 36 ;; | |
| 37 ;; This attempts to rectify the situation. | |
| 38 | |
| 502 | 39 (globally-declare-fboundp |
| 40 '(gtk-clist-clear | |
| 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)) | |
| 53 | |
| 462 | 54 (defun gtk-file-dialog-fill-file-list (dialog dir) |
| 55 (if (not dir) | |
| 56 (setq dir (get dialog 'x-file-dialog-current-dir nil))) | |
| 57 | |
| 58 (put dialog 'x-file-dialog-current-dir dir) | |
| 59 | |
| 60 (let ((list (get dialog 'x-file-dialog-files-list nil)) | |
| 502 | 61 ;(remotep (file-remote-p dir)) |
| 62 ) | |
| 462 | 63 (if (not list) |
| 64 nil | |
| 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. | |
| 502 | 70 (mapc #'(lambda (f) |
| 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))) | |
| 74 ) | |
| 75 (gtk-clist-append list (list f)))) | |
| 462 | 76 (directory-files dir nil |
| 77 (get dialog 'x-file-dialog-active-filter nil) | |
| 78 nil t)) | |
| 79 (gtk-clist-thaw list)))) | |
| 80 | |
| 81 (defun gtk-file-dialog-fill-directory-list (dialog dir) | |
| 82 (let ((subdirs (directory-files dir nil nil nil 5)) | |
| 502 | 83 ;(remotep (file-remote-p dir)) |
| 84 ;(selected-dir (get dialog 'x-file-dialog-current-dir "/")) | |
| 462 | 85 (directory-list (get dialog 'x-file-dialog-directory-list))) |
| 86 | |
| 87 (gtk-clist-freeze directory-list) | |
| 88 (gtk-clist-clear directory-list) | |
| 89 | |
| 90 (while subdirs | |
| 91 (if (equal "." (car subdirs)) | |
| 92 nil | |
| 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 | |
| 502 | 97 ;(not remotep) ; fix itself, shall we? |
| 98 ;(file-directory-p (expand-file-name (car subdirs) dir)) | |
| 99 ) | |
| 462 | 100 (gtk-clist-append directory-list (list (car subdirs))))) |
| 101 (pop subdirs)) | |
| 102 (gtk-clist-thaw directory-list))) | |
| 103 | |
| 104 (defun gtk-file-dialog-update-dropdown (dialog dir) | |
| 105 (let ((combo-box (get dialog 'x-file-dialog-select-list)) | |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
106 (components (nreverse |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
107 (delete "" (split-string-by-char dir directory-sep-char)))) |
| 462 | 108 (entries nil)) |
| 109 (while components | |
| 110 (push (concat "/" (mapconcat 'identity (reverse components) | |
| 111 (char-to-string directory-sep-char))) | |
| 112 entries) | |
| 113 (pop components)) | |
| 114 (push (expand-file-name "." "~/") entries) | |
| 115 (gtk-combo-set-popdown-strings combo-box (nreverse entries)))) | |
| 116 | |
| 117 (defun gtk-file-dialog-select-directory (dialog dir) | |
| 118 (gtk-file-dialog-fill-directory-list dialog dir) | |
| 119 (gtk-file-dialog-fill-file-list dialog dir) | |
| 120 (gtk-file-dialog-update-dropdown dialog dir)) | |
| 121 | |
| 122 (defun gtk-file-dialog-new (&rest keywords) | |
| 123 "Create a XEmacs file selection dialog. | |
| 124 Optional keyword arguments allowed: | |
| 125 | |
| 126 :title The title of the dialog | |
| 127 :initial-directory Initial directory to show | |
| 128 :filter-list List of filter descriptions and filters | |
| 129 :file-must-exist Whether the file must exist or not | |
| 130 :directory Look for a directory instead | |
| 131 :callback Function to call with one arg, the selection | |
| 132 " | |
| 133 (let* ((dialog (gtk-dialog-new)) | |
| 134 (vbox (gtk-dialog-vbox dialog)) | |
| 135 (dir (plist-get keywords :initial-directory default-directory)) | |
| 136 (button-area (gtk-dialog-action-area dialog)) | |
| 502 | 137 ;(initializing-gtk-file-dialog t) |
| 462 | 138 (select-box nil) |
| 139 button hbox) | |
| 140 | |
| 141 (put dialog 'type 'dialog) | |
| 142 | |
| 143 (gtk-window-set-title dialog (plist-get keywords :title "Select a file...")) | |
| 144 | |
| 145 (setq button (gtk-button-new-with-label "OK")) | |
| 146 (gtk-container-add button-area button) | |
| 147 (gtk-signal-connect button 'clicked | |
| 148 (lambda (button dialog) | |
| 149 (funcall | |
| 150 (get dialog 'x-file-dialog-callback 'ignore) | |
| 151 (gtk-entry-get-text | |
| 152 (get dialog 'x-file-dialog-entry nil))) | |
| 153 (gtk-widget-destroy dialog)) | |
| 154 dialog) | |
| 155 (put dialog 'x-file-dialog-ok-button button) | |
| 156 | |
| 157 (setq button (gtk-button-new-with-label "Cancel")) | |
| 158 (gtk-container-add button-area button) | |
| 159 (gtk-signal-connect button 'clicked | |
| 160 (lambda (button dialog) | |
| 161 (gtk-widget-destroy dialog)) dialog) | |
| 162 | |
| 163 (put dialog 'x-file-dialog-cancel-button button) | |
| 164 (put dialog 'x-file-dialog-callback (plist-get keywords :callback 'ignore)) | |
| 165 (put dialog 'x-file-dialog-construct-args keywords) | |
| 166 (put dialog 'x-file-dialog-current-dir dir) | |
| 167 | |
| 168 ;; Dropdown list of directories... | |
| 169 (setq select-box (gtk-combo-new)) | |
| 170 (gtk-combo-disable-activate select-box) | |
| 171 (gtk-box-pack-start vbox select-box nil nil 5) | |
| 172 (put dialog 'x-file-dialog-select-list select-box) | |
| 173 | |
| 174 ;; Hitting return in the entry will change dirs... | |
| 175 (gtk-signal-connect (gtk-combo-entry select-box) 'activate | |
| 176 (lambda (entry dialog) | |
| 177 (gtk-file-dialog-select-directory dialog | |
| 178 (gtk-entry-get-text entry))) | |
| 179 dialog) | |
| 180 | |
| 181 ;; Start laying out horizontally... | |
| 182 (setq hbox (gtk-hbox-new nil 0)) | |
| 183 (gtk-box-pack-start vbox hbox t t 5) | |
| 184 | |
| 185 ;; Directory listing | |
| 186 (let ((directories (gtk-clist-new-with-titles 1 '("Directories"))) | |
| 502 | 187 (scrolled (gtk-scrolled-window-new nil nil))) |
| 462 | 188 (gtk-container-add scrolled directories) |
| 189 (gtk-widget-set-usize scrolled 200 300) | |
| 190 (gtk-box-pack-start hbox scrolled t t 0) | |
| 191 (put dialog 'x-file-dialog-directory-list directories) | |
| 192 (put dialog 'x-file-dialog-directory-scrolled scrolled) | |
| 193 | |
| 194 (gtk-signal-connect directories 'select-row | |
| 195 (lambda (list row column event dialog) | |
| 196 (let ((dir (expand-file-name | |
| 197 (gtk-clist-get-text | |
| 198 (get dialog 'x-file-dialog-directory-list) | |
| 199 row column) | |
| 200 (get dialog 'x-file-dialog-current-dir)))) | |
| 201 (if (and (misc-user-event-p event) | |
| 202 (event-function event)) | |
| 203 (gtk-file-dialog-select-directory dialog dir) | |
| 204 (gtk-entry-set-text | |
| 205 (get dialog 'x-file-dialog-entry) | |
| 206 dir)))) | |
| 207 dialog) | |
| 208 ) | |
| 209 | |
| 210 (if (plist-get keywords :directory nil) | |
| 211 ;; Directory listings only do not need the file or filters buttons. | |
| 212 nil | |
| 213 ;; File listing | |
| 214 (let ((list (gtk-clist-new-with-titles 1 '("Files"))) | |
| 215 (scrolled (gtk-scrolled-window-new nil nil))) | |
| 216 (gtk-container-add scrolled list) | |
| 217 (gtk-widget-set-usize scrolled 200 300) | |
| 218 (gtk-box-pack-start hbox scrolled t t 0) | |
| 219 | |
| 220 (gtk-signal-connect list 'select-row | |
| 221 (lambda (list row column event dialog) | |
| 222 (gtk-entry-set-text | |
| 223 (get dialog 'x-file-dialog-entry nil) | |
| 224 (expand-file-name | |
| 225 (gtk-clist-get-text list row column) | |
| 226 (get dialog 'x-file-dialog-current-dir nil))) | |
| 227 (if (and (misc-user-event-p event) | |
| 228 (event-function event)) | |
| 229 ;; Got a double or triple click event... | |
| 230 (gtk-button-clicked | |
| 231 (get dialog 'x-file-dialog-ok-button nil)))) | |
| 232 dialog) | |
| 233 | |
| 234 (put dialog 'x-file-dialog-files-list list)) | |
| 235 | |
| 236 ;; Filters | |
| 237 (if (not (plist-get keywords :filter-list nil)) | |
| 238 ;; Don't need to bother packing this | |
| 239 nil | |
| 240 (setq hbox (gtk-hbox-new nil 0)) | |
| 241 (gtk-box-pack-start vbox hbox nil nil 0) | |
| 242 | |
| 243 (let ((label nil) | |
| 244 (options (plist-get keywords :filter-list nil)) | |
| 245 (omenu nil) | |
| 246 (menu nil) | |
| 247 (item nil)) | |
| 248 (setq omenu (gtk-option-menu-new) | |
| 249 menu (gtk-menu-new) | |
| 250 label (gtk-label-new "Filter: ")) | |
| 251 | |
| 252 (put dialog 'x-file-dialog-active-filter (cdr (car options))) | |
| 253 (mapc (lambda (o) | |
| 254 (setq item (gtk-menu-item-new-with-label (car o))) | |
| 255 (gtk-signal-connect item 'activate | |
| 256 (lambda (obj data) | |
| 257 (put (car data) 'x-file-dialog-active-filter (cdr data)) | |
| 258 (gtk-file-dialog-fill-file-list (car data) nil)) | |
| 259 (cons dialog (cdr o))) | |
| 260 (gtk-menu-append menu item) | |
| 261 (gtk-widget-show item)) options) | |
| 262 (gtk-option-menu-set-menu omenu menu) | |
| 263 (gtk-box-pack-end hbox omenu nil nil 0) | |
| 264 (gtk-box-pack-end hbox label nil nil 0)))) | |
| 265 | |
| 266 ;; Entry | |
| 267 (let ((entry (gtk-entry-new))) | |
| 268 (if (plist-get keywords :directory nil) | |
| 269 nil | |
| 270 (gtk-box-pack-start vbox entry nil nil 0)) | |
| 271 (if (plist-get keywords :file-must-exist nil) | |
| 272 (progn | |
| 273 (gtk-widget-set-sensitive (get dialog 'x-file-dialog-ok-button nil) nil) | |
| 274 (gtk-signal-connect entry 'changed | |
| 275 (lambda (entry dialog) | |
| 276 (gtk-widget-set-sensitive | |
| 277 (get dialog 'x-file-dialog-ok-button) | |
| 278 (file-exists-p (gtk-entry-get-text entry)))) | |
| 279 dialog))) | |
| 280 (put dialog 'x-file-dialog-entry entry)) | |
| 281 | |
| 282 (gtk-widget-realize dialog) | |
| 283 | |
| 284 | |
| 285 ;; Populate the file list if necessary | |
| 286 (gtk-file-dialog-select-directory dialog dir) | |
| 287 dialog)) | |
| 288 | |
| 289 (provide 'gtk-file-dialog) |