clim-utils.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;;; File dialogue stuff
   5 ;;
   6 ;; Dialogue box for file browing operations. Takes an object and puts
   7 ;; the resulting pathname into it (for now, this means we can only
   8 ;; handle single files). User can optionally provide acceptable file
   9 ;; extensions, which will disallow clicking on other files (the user
  10 ;; can override this by ctrl-clicking).
  11 ;;
  12 ;; This really ought to go somewhere in CLIM, but it uses code from
  13 ;; CLIM-LISTENER, so would probably need a package that doesn't exist
  14 ;; or for some of the listener functionality to be moved somewhere
  15 ;; useful.
  16
  17 (in-package :gsharp)
  18
  19 (defparameter *file-text-style*
  20   (make-text-style :sans-serif :roman :small))
  21 ;; Transport for holding pathname info between application frame and
  22 ;; caller
  23 (defstruct filespec (pathname))
  24 ;; FIXME: way to pass initargs to application gadget
  25 (defparameter *init-info* "")
  26
  27 (define-command-table path-input)
  28 ;; (defclass file-browser-pane (esa-pane-mixin application-pane) ())
  29 (define-gesture-name :adjust :pointer-button (:left :control))
  30 (define-gesture-name :hidden :keyboard (#\h :control))
  31
  32 (defun read-text-path (gadget)
  33   (let ((new-path (pathname (gadget-value gadget))))
  34     (if (clim-listener::directoryp new-path)
  35         (setf (current-path *application-frame*)
  36               new-path)
  37         (setf (current-path *application-frame*)
  38               (make-pathname :directory (pathname-directory new-path))))
  39     (redraw-file-browser-windows *application-frame*)))
  40
  41 (define-application-frame file-browser (standard-application-frame)
  42   ((current-path :initarg :path :accessor current-path)
  43    (extensions :initarg :extensions :accessor extensions :initform nil)
  44    (show-hidden :initarg :hidden :accessor show-hidden :initform nil)
  45    (sort-predicate :initarg :sort :accessor sort-predicate :initform
  46                    #'directory-alpha-sort)
  47    (final-file :initarg :file :accessor final-file
  48                :initform (make-filespec :pathname "")))
  49   (:menu-bar nil)
  50   (:panes
  51    (path-input :text-field :text-style *file-text-style*
  52                :command-table 'file-browser
  53                :value (get-gadget-value :path-input)
  54                :activate-callback #'read-text-path)
  55    (browser (make-pane 'application-pane
  56                        :width 800
  57                        :height 300
  58                        :text-style *file-text-style*
  59                        :command-table 'file-browser
  60                        :display-function 'display-folder))
  61    (ok-button
  62     :push-button :label "Ok"
  63     :activate-callback
  64     #'(lambda (gadget)
  65         (declare (ignore gadget))
  66         (setf (filespec-pathname (final-file *application-frame*))
  67               (pathname
  68                (gadget-value (find-pane-named *application-frame*
  69                                               'path-input))))
  70         (frame-exit *application-frame*)))
  71    (cancel-button
  72     :push-button :label "Cancel"
  73     :activate-callback
  74     #'(lambda (gadget)
  75         (declare (ignore gadget))
  76         (setf (filespec-pathname (final-file *application-frame*)) "")
  77         (frame-exit *application-frame*))))
  78   (:layouts
  79    (default
  80        (vertically ()
  81          path-input
  82          (scrolling () browser)
  83          (horizontally () ok-button cancel-button +fill+)))))
  84
  85 (defun redraw-file-browser-windows (frame)
  86   (redisplay-frame-pane frame
  87                         (find-pane-named frame 'browser)
  88                         :force-p t)
  89   (redisplay-frame-pane frame
  90                         (find-pane-named frame 'path-input)
  91                         :force-p t))
  92
  93 (defmethod display-folder (frame pane)
  94   (let* ((main-path (current-path frame))
  95          (path (if (clim-listener::directoryp main-path)
  96                    (clim-listener::show-directory-pathnames main-path)
  97                    (clim-listener::show-directory-pathnames (directory-name main-path)))))
  98     (browser-show-directory
  99      pane
 100      ;;   (clim-listener::show-directory-pathnames (current-path frame))
 101      path
 102      :show-hidden (show-hidden frame)
 103      :sort-predicate (sort-predicate frame))))
 104
 105 (defun dir-parent (path)
 106   (merge-pathnames (make-pathname :directory '(:relative :back))
 107                    path))
 108
 109 (defun parent-dir (path)
 110   (let ((dirs (pathname-directory path)))
 111     (make-pathname :directory (subseq dirs 0 (1- (length dirs))))))
 112
 113 (defun hiddenp (path)
 114   (char= (elt (if (clim-listener::directoryp path)
 115                   (directory-name path)
 116                   (pathname-name path))
 117               0)
 118          #\.))
 119 (defun directory-name (path)
 120   (car (last (pathname-directory path))))
 121
 122 (defun directory-alpha-sort (p1 p2)
 123   (let ((d1 (clim-listener::directoryp p1))
 124         (d2 (clim-listener::directoryp p2)))
 125     (if d1
 126         (if d2
 127             (string-lessp (directory-name p1) (directory-name p2))
 128             t)
 129         (if d2
 130             nil
 131             (or (string-lessp (pathname-name p1) (pathname-name p2))
 132                 (and (string-equal (pathname-name p1) (pathname-name p2))
 133                      (string-lessp (pathname-type p1) (pathname-type p2))))))))
 134
 135 (defun browser-show-directory (pane path
 136                                &key (show-hidden nil)
 137                                (sort-predicate #'directory-alpha-sort))
 138   (let* ((dir (coerce (directory path) 'simple-vector))
 139          (parent (parent-dir path)))
 140     (unless show-hidden
 141       (setf dir (sort (remove-if #'hiddenp dir) sort-predicate)))
 142     (formatting-table (pane)
 143       (dotimes (i (ceiling (/ (length dir) 3)))
 144         (formatting-row (pane)
 145           (dotimes (j 3)
 146             (unless (> (+ (* 3 i) j) (length dir))
 147               (formatting-cell (pane)
 148                 (if (= i 0 j)
 149                     ;; fixme: root dir
 150                     (with-output-as-presentation
 151                         (pane parent 'clim:pathname :single-box t)
 152                       (clim-listener::draw-icon
 153                        pane
 154                        (clim-listener::standard-icon "up-folder.xpm")
 155                        :extra-spacing 3)
 156                       (princ "Parent directory" pane))
 157                     (with-drawing-options
 158                         (pane :ink
 159                               (if (or (clim-listener::directoryp (aref dir (+ (* 3 i) j -1)))
 160                                       (file-filter (aref dir (+ (* 3 i) j -1))
 161                                                    *application-frame*))
 162                                   +black+
 163                                   +gray+))
 164                       (clim-listener::pretty-pretty-pathname
 165                        (aref dir (+ (* 3 i) j -1)) pane path)))))))))))
 166
 167 (define-file-browser-command (com-change-to-directory :name t :menu t)
 168     ((pathname 'clim:pathname :prompt "pathname"))
 169   (change-to-directory pathname *application-frame*))
 170
 171 (defun change-to-directory (pathname frame)
 172   (setf (current-path frame) pathname
 173         (gadget-value (find-pane-named frame 'path-input))
 174         (princ-to-string pathname))
 175   (redraw-file-browser-windows frame))
 176
 177 (defun file-filter (path frame)
 178   (when (pathname-type path)
 179     (if (extensions frame)
 180         (member (pathname-type path) (extensions frame)
 181                 :test #'string-equal)
 182         t)))
 183 (define-file-browser-command (com-toggle-hidden :name t :menu t
 184                                                :keystroke :hidden)
 185     ()
 186   (setf (show-hidden *application-frame*) (not (show-hidden *application-frame*)))
 187   (redraw-file-browser-windows *application-frame*))
 188
 189 (define-presentation-to-command-translator select-file
 190     (clim-listener::pathname com-select-file file-browser
 191                              :documentation "select file"
 192                              :tester ((object)
 193                                       (file-filter object *application-frame*)))
 194     (object)
 195   (list object))
 196
 197 (define-presentation-to-command-translator force-select-file
 198     (clim-listener::pathname com-select-file file-browser
 199                              :gesture :adjust
 200                              :documentation "select file"
 201                              :tester ((object)
 202                                       (not (clim-listener::directoryp object))))
 203     (object)
 204   (list object))
 205
 206 (define-file-browser-command (com-select-file :name t :menu t)
 207     ((pathname 'clim:pathname :prompt "pathname"))
 208   (let ((path (find-pane-named *application-frame* 'path-input)))
 209     (if (string= (gadget-value path) (princ-to-string pathname))
 210         (progn (setf (filespec-pathname (final-file *application-frame*)) pathname)
 211                (frame-exit *application-frame*))
 212         (progn (setf (gadget-value path) (princ-to-string pathname))
 213                (redraw-file-browser-windows *application-frame*)))))
 214
 215 (define-file-browser-command (com-load-file :name t :menu t)
 216     ((pathname 'clim:pathname :prompt "pathname"))
 217   (if (equal (filespec-pathname (final-file *application-frame*)) pathname)
 218       (frame-exit *application-frame*)
 219       (progn
 220         (setf (filespec-pathname (final-file *application-frame*)) pathname
 221               (gadget-value (find-pane-named *application-frame* 'path-input))
 222               (princ-to-string pathname))
 223         (redraw-file-browser-windows *application-frame*))))
 224
 225 (define-presentation-to-command-translator change-to-directory
 226     (clim-listener::pathname com-change-to-directory file-browser
 227                    :documentation  "change-to-directory"
 228                    :tester ((object) (clim-listener::directoryp object)))
 229     (object)
 230   (list object))
 231
 232 (defparameter *gadget-init-hash* (make-hash-table))
 233 (defun get-gadget-value (keyword)
 234   (gethash keyword *gadget-init-hash*))
 235 (defun set-gadget-defaults (gadget-pairs)
 236   (setf *gadget-init-hash* (make-hash-table))
 237   (do* ((gadget-pairs gadget-pairs (cddr gadget-pairs))
 238         (key (first gadget-pairs) (first gadget-pairs))
 239         (val (second gadget-pairs) (second gadget-pairs)))
 240        ((null gadget-pairs))
 241     (setf (gethash key *gadget-init-hash*) val)))
 242 (defun make-application-frame-with-gadgets (type &key gadget-vars frame-vars)
 243   (set-gadget-defaults gadget-vars)
 244   (apply #'make-application-frame type frame-vars))
 245
 246 (defun gui-get-pathname (&key initial-path extensions)
 247   ;; clunky way of getting default values into gadgets
 248   (unless initial-path
 249     (setf initial-path (directory-of-current-buffer)))
 250   (let* ((filespec (make-filespec :pathname ""))
 251          (frame (make-application-frame-with-gadgets
 252                  'file-browser
 253                  :gadget-vars (list :path-input (princ-to-string initial-path))
 254                  :frame-vars (list :width 600 :path initial-path
 255                                    :file filespec
 256                                    :extensions extensions))))
 257     (run-frame-top-level frame)
 258     (filespec-pathname filespec)))