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 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)