lisp/ezimage.el

   1 ;;; ezimage --- Generalized Image management
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008, 2009, 2010, 2011  Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Keywords: file, tags, tools
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; A few routines for placing an image over text that will work for any
  27 ;; Emacs implementation without error.  When images are not supported, then
  28 ;; they are just not displayed.
  29 ;;
  30 ;; The idea is that gui buffers (trees, buttons, etc) will have text
  31 ;; representations of the GUI elements.  These routines will replace the text
  32 ;; with an image when images are available.
  33 ;;
  34 ;; This file requires the `image' package if it is available.
  35
  36 (condition-case nil                     ; for older XEmacs
  37     (require 'image)
  38   (error nil))
  39
  40 ;;; Code:
  41 (defcustom ezimage-use-images (if (featurep 'xemacs)
  42                                   (and (fboundp 'make-image-specifier)
  43                                        window-system)
  44                                 (and (display-images-p)
  45                                      (image-type-available-p 'xpm)))
  46   "Non-nil means ezimage should display icons."
  47   :group 'ezimage
  48   :version "21.1"
  49   :type 'boolean)
  50
  51 ;;; Create our own version of defimage
  52 (eval-and-compile
  53
  54 (if (featurep 'emacs)
  55     (progn
  56       (defmacro defezimage (variable imagespec docstring)
  57         "Define VARIABLE as an image if `defimage' is not available.
  58 IMAGESPEC is the image data, and DOCSTRING is documentation for the image."
  59         `(progn
  60            (defimage ,variable ,imagespec ,docstring)
  61            (put (quote ,variable) 'ezimage t)))
  62
  63 ;; This hack is for the ezimage install which has an icons direcory for
  64 ;; the default icons to be used.
  65 ;; (add-to-list 'load-path
  66 ;;           (concat (file-name-directory
  67 ;;                    (locate-library "ezimage.el"))
  68 ;;                   "icons"))
  69
  70        )
  71
  72   ;; XEmacs.
  73   (if (not (fboundp 'make-glyph))
  74
  75       (defmacro defezimage (variable imagespec docstring)
  76         "Don't bother loading up an image...
  77 Argument VARIABLE is the variable to define.
  78 Argument IMAGESPEC is the list defining the image to create.
  79 Argument DOCSTRING is the documentation for VARIABLE."
  80         `(defvar ,variable nil ,docstring))
  81
  82     (defun ezimage-find-image-on-load-path (image)
  83       "Find the image file IMAGE on the load path."
  84       (let ((l (cons
  85                 ;; In XEmacs, try the data directory first (for an
  86                 ;; install in XEmacs proper.)   Search the load
  87                 ;; path next (for user installs)
  88                 (locate-data-directory "ezimage")
  89                 load-path))
  90             (r nil))
  91         (while (and l (not r))
  92           (if (file-exists-p (concat (car l) "/" image))
  93               (setq r (concat (car l) "/" image))
  94             (if (file-exists-p (concat (car l) "/icons/" image))
  95                 (setq r (concat (car l) "/icons/" image))
  96               ))
  97           (setq l (cdr l)))
  98         r))
  99
 100     (defun ezimage-convert-emacs21-imagespec-to-xemacs (spec)
 101       "Convert the Emacs21 image SPEC into an XEmacs image spec.
 102 The Emacs 21 spec is what I first learned, and is easy to convert."
 103       (let* ((sl (car spec))
 104              (itype (nth 1 sl))
 105              (ifile (nth 3 sl)))
 106         (vector itype ':file (ezimage-find-image-on-load-path ifile))))
 107
 108     (defmacro defezimage (variable imagespec docstring)
 109       "Define VARIABLE as an image if `defimage' is not available.
 110 IMAGESPEC is the image data, and DOCSTRING is documentation for the image."
 111       `(progn
 112          (defvar ,variable
 113            ;; The Emacs21 version of defimage looks just like the XEmacs image
 114            ;; specifier, except that it needs a :type keyword.  If we line
 115            ;; stuff up right, we can use this cheat to support XEmacs specifiers.
 116            (condition-case nil
 117                (make-glyph
 118                 (make-image-specifier
 119                  (ezimage-convert-emacs21-imagespec-to-xemacs (quote ,imagespec)))
 120                 'buffer)
 121              (error nil))
 122            ,docstring)
 123          (put ',variable 'ezimage t)))
 124
 125     )))
 126
 127 (defezimage ezimage-directory
 128   ((:type xpm :file "ezimage/dir.xpm" :ascent center))
 129   "Image used for empty directories.")
 130
 131 (defezimage ezimage-directory-plus
 132   ((:type xpm :file "ezimage/dir-plus.xpm" :ascent center))
 133   "Image used for closed directories with stuff in them.")
 134
 135 (defezimage ezimage-directory-minus
 136   ((:type xpm :file "ezimage/dir-minus.xpm" :ascent center))
 137   "Image used for open directories with stuff in them.")
 138
 139 (defezimage ezimage-page-plus
 140   ((:type xpm :file "ezimage/page-plus.xpm" :ascent center))
 141   "Image used for closed files with stuff in them.")
 142
 143 (defezimage ezimage-page-minus
 144   ((:type xpm :file "ezimage/page-minus.xpm" :ascent center))
 145   "Image used for open files with stuff in them.")
 146
 147 (defezimage ezimage-page
 148   ((:type xpm :file "ezimage/page.xpm" :ascent center))
 149   "Image used for files with nothing interesting in it.")
 150
 151 (defezimage ezimage-tag
 152   ((:type xpm :file "ezimage/tag.xpm" :ascent center))
 153   "Image used for tags.")
 154
 155 (defezimage ezimage-tag-plus
 156   ((:type xpm :file "ezimage/tag-plus.xpm" :ascent center))
 157   "Image used for closed tag groups.")
 158
 159 (defezimage ezimage-tag-minus
 160   ((:type xpm :file "ezimage/tag-minus.xpm" :ascent center))
 161   "Image used for open tags.")
 162
 163 (defezimage ezimage-tag-gt
 164   ((:type xpm :file "ezimage/tag-gt.xpm" :ascent center))
 165   "Image used for closed tags (with twist arrow).")
 166
 167 (defezimage ezimage-tag-v
 168   ((:type xpm :file "ezimage/tag-v.xpm" :ascent center))
 169   "Image used for open tags (with twist arrow).")
 170
 171 (defezimage ezimage-tag-type
 172   ((:type xpm :file "ezimage/tag-type.xpm" :ascent center))
 173   "Image used for tags that represent a data type.")
 174
 175 (defezimage ezimage-box-plus
 176   ((:type xpm :file "ezimage/box-plus.xpm" :ascent center))
 177   "Image of a closed box.")
 178
 179 (defezimage ezimage-box-minus
 180   ((:type xpm :file "ezimage/box-minus.xpm" :ascent center))
 181   "Image of an open box.")
 182
 183 (defezimage ezimage-mail
 184   ((:type xpm :file "ezimage/mail.xpm" :ascent center))
 185   "Image of an envelope.")
 186
 187 (defezimage ezimage-checkout
 188   ((:type xpm :file "ezimage/checkmark.xpm" :ascent center))
 189   "Image representing a checkmark.  For files checked out of a VC.")
 190
 191 (defezimage ezimage-object
 192   ((:type xpm :file "ezimage/bits.xpm" :ascent center))
 193   "Image representing bits (an object file.)")
 194
 195 (defezimage ezimage-object-out-of-date
 196   ((:type xpm :file "ezimage/bitsbang.xpm" :ascent center))
 197   "Image representing bits with a ! in it.  (An out of data object file.)")
 198
 199 (defezimage ezimage-label
 200   ((:type xpm :file "ezimage/label.xpm" :ascent center))
 201   "Image used for label prefix.")
 202
 203 (defezimage ezimage-lock
 204   ((:type xpm :file "ezimage/lock.xpm" :ascent center))
 205   "Image of a lock.  Used for Read Only, or private.")
 206
 207 (defezimage ezimage-unlock
 208   ((:type xpm :file "ezimage/unlock.xpm" :ascent center))
 209   "Image of an unlocked lock.")
 210
 211 (defezimage ezimage-key
 212   ((:type xpm :file "ezimage/key.xpm" :ascent center))
 213   "Image of a key.")
 214
 215 (defezimage ezimage-document-tag
 216   ((:type xpm :file "ezimage/doc.xpm" :ascent center))
 217   "Image used to indicate documentation available.")
 218
 219 (defezimage ezimage-document-plus
 220   ((:type xpm :file "ezimage/doc-plus.xpm" :ascent center))
 221   "Image used to indicate closed documentation.")
 222
 223 (defezimage ezimage-document-minus
 224   ((:type xpm :file "ezimage/doc-minus.xpm" :ascent center))
 225   "Image used to indicate open documentation.")
 226
 227 (defezimage ezimage-info-tag
 228   ((:type xpm :file "ezimage/info.xpm" :ascent center))
 229   "Image used to indicate more information available.")
 230
 231 (defvar ezimage-expand-image-button-alist
 232   '(
 233     ;; here are some standard representations
 234     ("<+>" . ezimage-directory-plus)
 235     ("<->" . ezimage-directory-minus)
 236     ("< >" . ezimage-directory)
 237     ("[+]" . ezimage-page-plus)
 238     ("[-]" . ezimage-page-minus)
 239     ("[?]" . ezimage-page)
 240     ("[ ]" . ezimage-page)
 241     ("{+}" . ezimage-box-plus)
 242     ("{-}" . ezimage-box-minus)
 243     ;; Some vaguely representitive entries
 244     ("*" . ezimage-checkout)
 245     ("#" . ezimage-object)
 246     ("!" . ezimage-object-out-of-date)
 247     ("%" . ezimage-lock)
 248     )
 249   "List of text and image associations.")
 250
 251 (defun ezimage-insert-image-button-maybe (start length &optional string)
 252   "Insert an image button based on text starting at START for LENGTH chars.
 253 If buttontext is unknown, just insert that text.
 254 If we have an image associated with it, use that image.
 255 Optional argument STRING is a string upon which to add text properties."
 256   (when ezimage-use-images
 257     (let* ((bt (buffer-substring start (+ length start)))
 258            (a (assoc bt ezimage-expand-image-button-alist)))
 259       ;; Regular images (created with `insert-image' are intangible
 260       ;; which (I suppose) make them more compatible with XEmacs 21.
 261       ;; Unfortunatly, there is a giant pile o code dependent on the
 262       ;; underlying text.  This means if we leave it tangible, then I
 263       ;; don't have to change said giant piles o code.
 264       (if (and a (symbol-value (cdr a)))
 265           (ezimage-insert-over-text (symbol-value (cdr a))
 266                                     start
 267                                     (+ start (length bt))))))
 268   string)
 269
 270 (defun ezimage-image-over-string (string &optional alist)
 271   "Insert over the text in STRING an image found in ALIST.
 272 Return STRING with properties applied."
 273   (if ezimage-use-images
 274       (let ((a (assoc string alist)))
 275         (if (and a (symbol-value (cdr a)))
 276             (ezimage-insert-over-text (symbol-value (cdr a))
 277                                       0 (length string)
 278                                       string)
 279           string))
 280     string))
 281
 282 (defun ezimage-insert-over-text (image start end &optional string)
 283   "Place IMAGE over the text between START and END.
 284 Assumes the image is part of a GUI and can be clicked on.
 285 Optional argument STRING is a string upon which to add text properties."
 286   (when ezimage-use-images
 287     (add-text-properties start end
 288                          (if (featurep 'xemacs)
 289                              (list 'end-glyph image
 290                                    'rear-nonsticky (list 'display)
 291                                    'invisible t
 292                                    'detachable t)
 293                            (list 'display image
 294                                  'rear-nonsticky (list 'display)))
 295                          string))
 296   string)
 297
 298 (defun ezimage-image-association-dump ()
 299   "Dump out the current state of the Ezimage image alist.
 300 See `ezimage-expand-image-button-alist' for details."
 301   (interactive)
 302   (with-output-to-temp-buffer "*Ezimage Images*"
 303     (with-current-buffer "*Ezimage Images*"
 304       (goto-char (point-max))
 305       (insert "Ezimage image cache.\n\n")
 306       (let ((start (point)) (end nil))
 307         (insert "Image\tText\tImage Name")
 308         (setq end (point))
 309         (insert "\n")
 310         (put-text-property start end 'face 'underline))
 311       (let ((ia ezimage-expand-image-button-alist))
 312         (while ia
 313           (let ((start (point)))
 314             (insert (car (car ia)))
 315             (insert "\t")
 316             (ezimage-insert-image-button-maybe start
 317                                                 (length (car (car ia))))
 318             (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n"))
 319           (setq ia (cdr ia)))))))
 320
 321 (defun ezimage-image-dump ()
 322   "Dump out the current state of the Ezimage image alist.
 323 See `ezimage-expand-image-button-alist' for details."
 324   (interactive)
 325   (with-output-to-temp-buffer "*Ezimage Images*"
 326     (with-current-buffer "*Ezimage Images*"
 327       (goto-char (point-max))
 328       (insert "Ezimage image cache.\n\n")
 329       (let ((start (point)) (end nil))
 330         (insert "Image\tImage Name")
 331         (setq end (point))
 332         (insert "\n")
 333         (put-text-property start end 'face 'underline))
 334       (let ((ia (ezimage-all-images)))
 335         (while ia
 336           (let ((start (point)))
 337             (insert "cm")
 338             (ezimage-insert-over-text (symbol-value (car ia)) start (point))
 339             (insert "\t" (format "%s" (car ia)) "\n"))
 340           (setq ia (cdr ia)))))))
 341
 342 (defun ezimage-all-images ()
 343   "Return a list of all variables containing ez images."
 344   (let ((ans nil))
 345     (mapatoms (lambda (sym)
 346                 (if (get sym 'ezimage) (setq ans (cons sym ans)))))
 347     (setq ans (sort ans (lambda (a b)
 348                           (string< (symbol-name a) (symbol-name b)))))
 349     ans))
 350
 351 (provide 'ezimage)
 352
 353 ;;; sb-image.el ends here