cgit.sxemacs.org Git - sxemacs/blob - lisp/gtk-file-dialog.el

   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 SXEmacs.
   9
  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.
  14
  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.
  19
  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/>.
  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
  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
  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))
  61         ;(remotep (file-remote-p dir)))
  62         )
  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.
  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))))
  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))
  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)))
  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
  97                 ;(not remotep)          ; fix itself, shall we?
  98                 ;(file-directory-p (expand-file-name (car subdirs) dir)))
  99                 )
 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))
 106         (components (reverse
 107                      (delete ""
 108                              (split-string dir
 109                                            (concat "[" (char-to-string directory-sep-char) "]")))))
 110         (entries nil))
 111
 112     (while components
 113       (push (concat "/" (mapconcat 'identity (reverse components)
 114                                    (char-to-string directory-sep-char)))
 115             entries)
 116       (pop components))
 117     (push (expand-file-name "." "~/") entries)
 118     (gtk-combo-set-popdown-strings combo-box (nreverse entries))))
 119
 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))
 124
 125 (defun gtk-file-dialog-new (&rest keywords)
 126   "Create a XEmacs file selection dialog.
 127 Optional keyword arguments allowed:
 128
 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
 135 "
 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)
 141          (select-box nil)
 142          button hbox)
 143
 144     (put dialog 'type 'dialog)
 145
 146     (gtk-window-set-title dialog (plist-get keywords :title "Select a file..."))
 147
 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)
 152                           (funcall
 153                            (get dialog 'x-file-dialog-callback 'ignore)
 154                            (gtk-entry-get-text
 155                             (get dialog 'x-file-dialog-entry nil)))
 156                           (gtk-widget-destroy dialog))
 157                         dialog)
 158     (put dialog 'x-file-dialog-ok-button button)
 159
 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)
 165
 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)
 170
 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)
 176
 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)))
 182                         dialog)
 183
 184     ;; Start laying out horizontally...
 185     (setq hbox (gtk-hbox-new nil 0))
 186     (gtk-box-pack-start vbox hbox t t 5)
 187
 188     ;; Directory listing
 189     (let ((directories (gtk-clist-new-with-titles 1 '("Directories")))
 190           (scrolled (gtk-scrolled-window-new nil nil))
 191           ;(item nil))
 192           )
 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)