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)