lisp/ezimage.el

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