| 1 | ;;; image.el --- image API |
| 2 | |
| 3 | ;; Copyright (C) 1998, 99, 2000, 01, 04 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Maintainer: FSF |
| 6 | ;; Keywords: multimedia |
| 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 2, or (at your option) |
| 13 | ;; 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; see the file COPYING. If not, write to the |
| 22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 23 | ;; Boston, MA 02111-1307, USA. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;;; Code: |
| 28 | |
| 29 | |
| 30 | (defgroup image () |
| 31 | "Image support." |
| 32 | :group 'multimedia) |
| 33 | |
| 34 | |
| 35 | (defconst image-type-regexps |
| 36 | '(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm) |
| 37 | ("\\`P[1-6]" . pbm) |
| 38 | ("\\`GIF8" . gif) |
| 39 | ("\\`\211PNG\r\n" . png) |
| 40 | ("\\`[\t\n\r ]*#define" . xbm) |
| 41 | ("\\`\\(MM\0\\*\\|II\\*\0\\)" . tiff) |
| 42 | ("\\`[\t\n\r ]*%!PS" . postscript) |
| 43 | ("\\`\xff\xd8" . (image-jpeg-p . jpeg))) |
| 44 | "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. |
| 45 | When the first bytes of an image file match REGEXP, it is assumed to |
| 46 | be of image type IMAGE-TYPE if IMAGE-TYPE is a symbol. If not a symbol, |
| 47 | IMAGE-TYPE must be a pair (PREDICATE . TYPE). PREDICATE is called |
| 48 | with one argument, a string containing the image data. If PREDICATE returns |
| 49 | a non-nil value, TYPE is the image's type.") |
| 50 | |
| 51 | ;;;###autoload |
| 52 | (defvar image-library-alist nil |
| 53 | "Alist of image types vs external libraries needed to display them. |
| 54 | |
| 55 | Each element is a list (IMAGE-TYPE LIBRARY...), where the car is a symbol |
| 56 | representing a supported image type, and the rest are strings giving |
| 57 | alternate filenames for the corresponding external libraries to load. |
| 58 | They are tried in the order they appear on the list; if none of them can |
| 59 | be loaded, the running session of Emacs won't display the image type. |
| 60 | No entries are needed for pbm and xbm images; they're always supported.") |
| 61 | ;;;###autoload (put 'image-library-alist 'risky-local-variable t) |
| 62 | |
| 63 | (defun image-jpeg-p (data) |
| 64 | "Value is non-nil if DATA, a string, consists of JFIF image data. |
| 65 | We accept the tag Exif because that is the same format." |
| 66 | (when (string-match "\\`\xff\xd8" data) |
| 67 | (catch 'jfif |
| 68 | (let ((len (length data)) (i 2)) |
| 69 | (while (< i len) |
| 70 | (when (/= (aref data i) #xff) |
| 71 | (throw 'jfif nil)) |
| 72 | (setq i (1+ i)) |
| 73 | (when (>= (+ i 2) len) |
| 74 | (throw 'jfif nil)) |
| 75 | (let ((nbytes (+ (lsh (aref data (+ i 1)) 8) |
| 76 | (aref data (+ i 2)))) |
| 77 | (code (aref data i))) |
| 78 | (when (and (>= code #xe0) (<= code #xef)) |
| 79 | ;; APP0 LEN1 LEN2 "JFIF\0" |
| 80 | (throw 'jfif |
| 81 | (string-match "JFIF\\|Exif" |
| 82 | (substring data i (min (+ i nbytes) len))))) |
| 83 | (setq i (+ i 1 nbytes)))))))) |
| 84 | |
| 85 | |
| 86 | ;;;###autoload |
| 87 | (defun image-type-from-data (data) |
| 88 | "Determine the image type from image data DATA. |
| 89 | Value is a symbol specifying the image type or nil if type cannot |
| 90 | be determined." |
| 91 | (let ((types image-type-regexps) |
| 92 | type) |
| 93 | (while (and types (null type)) |
| 94 | (let ((regexp (car (car types))) |
| 95 | (image-type (cdr (car types)))) |
| 96 | (when (or (and (symbolp image-type) |
| 97 | (string-match regexp data)) |
| 98 | (and (consp image-type) |
| 99 | (funcall (car image-type) data) |
| 100 | (setq image-type (cdr image-type)))) |
| 101 | (setq type image-type)) |
| 102 | (setq types (cdr types)))) |
| 103 | type)) |
| 104 | |
| 105 | |
| 106 | ;;;###autoload |
| 107 | (defun image-type-from-file-header (file) |
| 108 | "Determine the type of image file FILE from its first few bytes. |
| 109 | Value is a symbol specifying the image type, or nil if type cannot |
| 110 | be determined." |
| 111 | (unless (file-name-directory file) |
| 112 | (setq file (expand-file-name file data-directory))) |
| 113 | (setq file (expand-file-name file)) |
| 114 | (let ((header (with-temp-buffer |
| 115 | (set-buffer-multibyte nil) |
| 116 | (insert-file-contents-literally file nil 0 256) |
| 117 | (buffer-string)))) |
| 118 | (image-type-from-data header))) |
| 119 | |
| 120 | |
| 121 | ;;;###autoload |
| 122 | (defun image-type-available-p (type) |
| 123 | "Value is non-nil if image type TYPE is available. |
| 124 | Image types are symbols like `xbm' or `jpeg'." |
| 125 | (and (fboundp 'init-image-library) |
| 126 | (init-image-library type image-library-alist))) |
| 127 | |
| 128 | ;;;###autoload |
| 129 | (defun create-image (file-or-data &optional type data-p &rest props) |
| 130 | "Create an image. |
| 131 | FILE-OR-DATA is an image file name or image data. |
| 132 | Optional TYPE is a symbol describing the image type. If TYPE is omitted |
| 133 | or nil, try to determine the image type from its first few bytes |
| 134 | of image data. If that doesn't work, and FILE-OR-DATA is a file name, |
| 135 | use its file extension as image type. |
| 136 | Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data. |
| 137 | Optional PROPS are additional image attributes to assign to the image, |
| 138 | like, e.g. `:mask MASK'. |
| 139 | Value is the image created, or nil if images of type TYPE are not supported." |
| 140 | (when (and (not data-p) (not (stringp file-or-data))) |
| 141 | (error "Invalid image file name `%s'" file-or-data)) |
| 142 | (cond ((null data-p) |
| 143 | ;; FILE-OR-DATA is a file name. |
| 144 | (unless (or type |
| 145 | (setq type (image-type-from-file-header file-or-data))) |
| 146 | (let ((extension (file-name-extension file-or-data))) |
| 147 | (unless extension |
| 148 | (error "Cannot determine image type")) |
| 149 | (setq type (intern extension))))) |
| 150 | (t |
| 151 | ;; FILE-OR-DATA contains image data. |
| 152 | (unless type |
| 153 | (setq type (image-type-from-data file-or-data))))) |
| 154 | (unless type |
| 155 | (error "Cannot determine image type")) |
| 156 | (unless (symbolp type) |
| 157 | (error "Invalid image type `%s'" type)) |
| 158 | (when (image-type-available-p type) |
| 159 | (append (list 'image :type type (if data-p :data :file) file-or-data) |
| 160 | props))) |
| 161 | |
| 162 | |
| 163 | ;;;###autoload |
| 164 | (defun put-image (image pos &optional string area) |
| 165 | "Put image IMAGE in front of POS in the current buffer. |
| 166 | IMAGE must be an image created with `create-image' or `defimage'. |
| 167 | IMAGE is displayed by putting an overlay into the current buffer with a |
| 168 | `before-string' STRING that has a `display' property whose value is the |
| 169 | image. STRING is defaulted if you omit it. |
| 170 | POS may be an integer or marker. |
| 171 | AREA is where to display the image. AREA nil or omitted means |
| 172 | display it in the text area, a value of `left-margin' means |
| 173 | display it in the left marginal area, a value of `right-margin' |
| 174 | means display it in the right marginal area." |
| 175 | (unless string (setq string "x")) |
| 176 | (let ((buffer (current-buffer))) |
| 177 | (unless (eq (car-safe image) 'image) |
| 178 | (error "Not an image: %s" image)) |
| 179 | (unless (or (null area) (memq area '(left-margin right-margin))) |
| 180 | (error "Invalid area %s" area)) |
| 181 | (setq string (copy-sequence string)) |
| 182 | (let ((overlay (make-overlay pos pos buffer)) |
| 183 | (prop (if (null area) image (list (list 'margin area) image)))) |
| 184 | (put-text-property 0 (length string) 'display prop string) |
| 185 | (overlay-put overlay 'put-image t) |
| 186 | (overlay-put overlay 'before-string string)))) |
| 187 | |
| 188 | |
| 189 | ;;;###autoload |
| 190 | (defun insert-image (image &optional string area slice) |
| 191 | "Insert IMAGE into current buffer at point. |
| 192 | IMAGE is displayed by inserting STRING into the current buffer |
| 193 | with a `display' property whose value is the image. STRING is |
| 194 | defaulted if you omit it. |
| 195 | AREA is where to display the image. AREA nil or omitted means |
| 196 | display it in the text area, a value of `left-margin' means |
| 197 | display it in the left marginal area, a value of `right-margin' |
| 198 | means display it in the right marginal area. |
| 199 | SLICE specifies slice of IMAGE to insert. SLICE nil or omitted |
| 200 | means insert whole image. SLICE is a list (X Y WIDTH HEIGHT) |
| 201 | specifying the X and Y positions and WIDTH and HEIGHT of image area |
| 202 | to insert. A float value 0.0 - 1.0 means relative to the width or |
| 203 | height of the image; integer values are taken as pixel values." |
| 204 | ;; Use a space as least likely to cause trouble when it's a hidden |
| 205 | ;; character in the buffer. |
| 206 | (unless string (setq string " ")) |
| 207 | (unless (eq (car-safe image) 'image) |
| 208 | (error "Not an image: %s" image)) |
| 209 | (unless (or (null area) (memq area '(left-margin right-margin))) |
| 210 | (error "Invalid area %s" area)) |
| 211 | (if area |
| 212 | (setq image (list (list 'margin area) image)) |
| 213 | ;; Cons up a new spec equal but not eq to `image' so that |
| 214 | ;; inserting it twice in a row (adjacently) displays two copies of |
| 215 | ;; the image. Don't try to avoid this by looking at the display |
| 216 | ;; properties on either side so that we DTRT more often with |
| 217 | ;; cut-and-paste. (Yanking killed image text next to another copy |
| 218 | ;; of it loses anyway.) |
| 219 | (setq image (cons 'image (cdr image)))) |
| 220 | (let ((start (point))) |
| 221 | (insert string) |
| 222 | (add-text-properties start (point) |
| 223 | `(display ,(if slice |
| 224 | (list (cons 'slice slice) image) |
| 225 | image) rear-nonsticky (display))))) |
| 226 | |
| 227 | |
| 228 | (defun insert-sliced-image (image &optional string area rows cols) |
| 229 | (unless string (setq string " ")) |
| 230 | (unless (eq (car-safe image) 'image) |
| 231 | (error "Not an image: %s" image)) |
| 232 | (unless (or (null area) (memq area '(left-margin right-margin))) |
| 233 | (error "Invalid area %s" area)) |
| 234 | (if area |
| 235 | (setq image (list (list 'margin area) image)) |
| 236 | ;; Cons up a new spec equal but not eq to `image' so that |
| 237 | ;; inserting it twice in a row (adjacently) displays two copies of |
| 238 | ;; the image. Don't try to avoid this by looking at the display |
| 239 | ;; properties on either side so that we DTRT more often with |
| 240 | ;; cut-and-paste. (Yanking killed image text next to another copy |
| 241 | ;; of it loses anyway.) |
| 242 | (setq image (cons 'image (cdr image)))) |
| 243 | (let ((x 0.0) (dx (/ 1.0001 (or cols 1))) |
| 244 | (y 0.0) (dy (/ 1.0001 (or rows 1)))) |
| 245 | (while (< y 1.0) |
| 246 | (while (< x 1.0) |
| 247 | (let ((start (point))) |
| 248 | (insert string) |
| 249 | (add-text-properties start (point) |
| 250 | `(display ,(list (list 'slice x y dx dy) image) |
| 251 | rear-nonsticky (display))) |
| 252 | (setq x (+ x dx)))) |
| 253 | (setq x 0.0 |
| 254 | y (+ y dy)) |
| 255 | (insert (propertize "\n" 'line-height 0))))) |
| 256 | |
| 257 | |
| 258 | |
| 259 | ;;;###autoload |
| 260 | (defun remove-images (start end &optional buffer) |
| 261 | "Remove images between START and END in BUFFER. |
| 262 | Remove only images that were put in BUFFER with calls to `put-image'. |
| 263 | BUFFER nil or omitted means use the current buffer." |
| 264 | (unless buffer |
| 265 | (setq buffer (current-buffer))) |
| 266 | (let ((overlays (overlays-in start end))) |
| 267 | (while overlays |
| 268 | (let ((overlay (car overlays))) |
| 269 | (when (overlay-get overlay 'put-image) |
| 270 | (delete-overlay overlay))) |
| 271 | (setq overlays (cdr overlays))))) |
| 272 | |
| 273 | |
| 274 | ;;;###autoload |
| 275 | (defun find-image (specs) |
| 276 | "Find an image, choosing one of a list of image specifications. |
| 277 | |
| 278 | SPECS is a list of image specifications. |
| 279 | |
| 280 | Each image specification in SPECS is a property list. The contents of |
| 281 | a specification are image type dependent. All specifications must at |
| 282 | least contain the properties `:type TYPE' and either `:file FILE' or |
| 283 | `:data DATA', where TYPE is a symbol specifying the image type, |
| 284 | e.g. `xbm', FILE is the file to load the image from, and DATA is a |
| 285 | string containing the actual image data. The specification whose TYPE |
| 286 | is supported, and FILE exists, is used to construct the image |
| 287 | specification to be returned. Return nil if no specification is |
| 288 | satisfied. |
| 289 | |
| 290 | The image is looked for first on `load-path' and then in `data-directory'." |
| 291 | (let (image) |
| 292 | (while (and specs (null image)) |
| 293 | (let* ((spec (car specs)) |
| 294 | (type (plist-get spec :type)) |
| 295 | (data (plist-get spec :data)) |
| 296 | (file (plist-get spec :file)) |
| 297 | found) |
| 298 | (when (image-type-available-p type) |
| 299 | (cond ((stringp file) |
| 300 | (let ((path load-path)) |
| 301 | (while (and (not found) path) |
| 302 | (let ((try-file (expand-file-name file (car path)))) |
| 303 | (when (file-readable-p try-file) |
| 304 | (setq found try-file))) |
| 305 | (setq path (cdr path))) |
| 306 | (unless found |
| 307 | (let ((try-file (expand-file-name file data-directory))) |
| 308 | (if (file-readable-p try-file) |
| 309 | (setq found try-file)))) |
| 310 | (if found |
| 311 | (setq image |
| 312 | (cons 'image (plist-put (copy-sequence spec) |
| 313 | :file found)))))) |
| 314 | ((not (null data)) |
| 315 | (setq image (cons 'image spec))))) |
| 316 | (setq specs (cdr specs)))) |
| 317 | image)) |
| 318 | |
| 319 | |
| 320 | ;;;###autoload |
| 321 | (defmacro defimage (symbol specs &optional doc) |
| 322 | "Define SYMBOL as an image. |
| 323 | |
| 324 | SPECS is a list of image specifications. DOC is an optional |
| 325 | documentation string. |
| 326 | |
| 327 | Each image specification in SPECS is a property list. The contents of |
| 328 | a specification are image type dependent. All specifications must at |
| 329 | least contain the properties `:type TYPE' and either `:file FILE' or |
| 330 | `:data DATA', where TYPE is a symbol specifying the image type, |
| 331 | e.g. `xbm', FILE is the file to load the image from, and DATA is a |
| 332 | string containing the actual image data. The first image |
| 333 | specification whose TYPE is supported, and FILE exists, is used to |
| 334 | define SYMBOL. |
| 335 | |
| 336 | Example: |
| 337 | |
| 338 | (defimage test-image ((:type xpm :file \"~/test1.xpm\") |
| 339 | (:type xbm :file \"~/test1.xbm\")))" |
| 340 | `(defvar ,symbol (find-image ',specs) ,doc)) |
| 341 | |
| 342 | |
| 343 | (provide 'image) |
| 344 | |
| 345 | ;;; arch-tag: 8e76a07b-eb48-4f3e-a7a0-1a7ba9f096b3 |
| 346 | ;;; image.el ends here |