cgit.sxemacs.org Git - packages/blob - xemacs-packages/x-symbol/lisp/x-symbol-image.el

   1 ;;; x-symbol-image.el --- display glyphs at the end of image insertion commands
   2
   3 ;; Copyright (C) 1997-1999, 2001, 2003 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Christoph Wedler <wedler@users.sourceforge.net>
   6 ;; Maintainer: (Please use `M-x x-symbol-package-bug' to contact the maintainer)
   7 ;; Version: 4.5
   8 ;; Keywords: WYSIWYG, LaTeX, HTML, wp, math, internationalization
   9 ;; X-URL: http://x-symbol.sourceforge.net/
  10
  11 ;; This program 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 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program 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 this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; If you want to use package x-symbol, please visit the URL (use
  28 ;; \\[x-symbol-package-web]) and read the info (use \\[x-symbol-package-info]).
  29
  30 ;; This file requires file `x-symbol.el which does some initialization.  Thus,
  31 ;; do not put any `defcustom' commands into this file.  If you think some
  32 ;; variables in this files should be customized, move them to file
  33 ;; `x-symbol-vars.el'.
  34
  35 ;;; Code:
  36
  37 (provide 'x-symbol-image)
  38 (require 'x-symbol)
  39 (eval-when-compile (require 'cl))
  40
  41
  42 \f
  43 ;;;;##########################################################################
  44 ;;;;  Main code
  45 ;;;;##########################################################################
  46
  47
  48 (defvar x-symbol-image-process-buffer "*x-symbol-image conversion*"
  49   "Name of the image conversion buffer.")
  50
  51 (defvar x-symbol-image-process-name "Image-Conversion"
  52   "Name of the image conversion process.")
  53
  54 (defvar x-symbol-image-highlight-map
  55   (let ((map (make-sparse-keymap)))
  56     ;; CW: two independend `when's or one `if' or 2*2 `when's ?
  57     (if (lookup-key global-map [(button2)])
  58         (progn
  59           ;; XEmacs bindings
  60           (define-key map [(button2)] 'x-symbol-image-mouse-editor)
  61           (define-key map [(button3)] 'x-symbol-image-highlight-menu))
  62       ;; Emacs bindings
  63       (define-key map [(mouse-2)] 'x-symbol-image-mouse-editor)
  64       (define-key map [(mouse-3)] 'x-symbol-image-highlight-menu))
  65     map)
  66   "Keymap for mouse event over image insertion commands.")
  67
  68
  69 ;;;===========================================================================
  70 ;;;  Internal variables
  71 ;;;===========================================================================
  72
  73 (defun x-symbol-image-try-special (image)
  74   "Return image for image specification IMAGE or [nothing].
  75 IMAGE is an element in `x-symbol-image-special-glyphs'."
  76   (or (and x-symbol-image-data-directory
  77            (x-symbol-create-image
  78             (expand-file-name (car image) x-symbol-image-data-directory)
  79             (cdr image)))
  80       (and (featurep 'xemacs) [nothing])))
  81
  82 (defvar x-symbol-image-broken-image
  83   (x-symbol-image-try-special (first x-symbol-image-special-glyphs))
  84   "Image to represent broken image files.
  85 IMAGE is an element in `x-symbol-image-special-glyphs'.")
  86
  87 (defvar x-symbol-image-create-image
  88   (x-symbol-image-try-special (second x-symbol-image-special-glyphs))
  89   "Image to represent image files which are currently converted.
  90 IMAGE is an element in `x-symbol-image-special-glyphs'.")
  91
  92 (defvar x-symbol-image-design-glyph
  93   (x-symbol-make-glyph (x-symbol-image-try-special
  94                         (third x-symbol-image-special-glyphs)))
  95   "Glyph to represent image files still to be designed.
  96 IMAGE is an element in `x-symbol-image-special-glyphs'.")
  97
  98 (defvar x-symbol-image-locked-glyph
  99   (x-symbol-make-glyph (x-symbol-image-try-special
 100                         (fourth x-symbol-image-special-glyphs)))
 101   "Glyph to represent locked image files.
 102 IMAGE is an element in `x-symbol-image-special-glyphs'.")
 103
 104 (defvar x-symbol-image-remote-glyph
 105   (x-symbol-make-glyph (x-symbol-image-try-special
 106                         (fifth x-symbol-image-special-glyphs)))
 107   "Glyph to represent \"remote\" image files.
 108 IMAGE is an element in `x-symbol-image-special-glyphs'.")
 109
 110 (defvar x-symbol-image-junk-glyph
 111   (x-symbol-make-glyph (x-symbol-image-try-special
 112                         (sixth x-symbol-image-special-glyphs)))
 113   "Glyph to represent \"junk\" image files.
 114 IMAGE is an element in `x-symbol-image-special-glyphs'.")
 115
 116 (defvar x-symbol-image-buffer-extents nil
 117   "Internal variable.  Extents for image commands in the current buffer.")
 118 (make-variable-buffer-local 'x-symbol-image-buffer-extents)
 119 (put 'x-symbol-image-buffer-extents 'permanent-local t)
 120
 121 (defvar x-symbol-image-memory-cache nil
 122   "Internal variable.  Buffer local memory cache for glyphs.
 123 Each element has the form (FILE FULL . GLYPH) where FILE is the given
 124 image file name, FULL is the full file name and GLYPH is the glyph used
 125 for that image file.  If GLYPH is nil, it is not created yet.  See also
 126 `x-symbol-image-use-remote'.  The memory cache is flushed with
 127 `x-symbol-image-init-memory-cache'.")
 128
 129 (make-variable-buffer-local 'x-symbol-image-memory-cache)
 130
 131 (defvar x-symbol-image-all-recursive-dirs nil
 132   "Internal variable.  Used by `x-symbol-image-searchpath'.")
 133 (defvar x-symbol-image-all-dirs nil
 134   "Internal variable.  Used by `x-symbol-image-searchpath'.")
 135
 136
 137 ;;;===========================================================================
 138 ;;;  Main functions
 139 ;;;===========================================================================
 140
 141 ;;;###autoload
 142 (defun x-symbol-image-parse-buffer (&optional update-cache)
 143   "*Parse buffer to find image insertion commands.
 144 Parse buffer to display glyphs at the end of image insertion commands.
 145 Image files are converted to \"image cache files\" with images not
 146 bigger than `x-symbol-image-max-width' and `x-symbol-image-max-height'
 147 having a image format XEmacs understands.  The conversion is done by a
 148 program determined by `x-symbol-image-converter', currently you need
 149 \"convert\" from ImageMagick.  To make this conversion fast, we use
 150 asynchronous processes and two cache hierarchies:
 151
 152  * Memory cache (`x-symbol-image-memory-cache'): buffer-local alist
 153    FILE.eps -> GLYPH, see also `x-symbol-image-use-remote'.
 154  * File cache: the image cache file, mentioned above, are kept, see also
 155    `x-symbol-image-update-cache', which is shadowed by a non-nil
 156    UPDATE-CACHE and `x-symbol-image-cache-directories'.
 157
 158 When the mouse is over an image insertion command, it is highlighted.
 159 button2 starts an image editor, see `x-symbol-image-editor-alist'.
 160 button3 pops up a menu, see `x-symbol-image-menu'.
 161
 162 The image insertion commands are recognized by keywords in the language
 163 access `x-symbol-LANG-image-keywords' whose value have the form
 164   (IMAGE-REGEXP KEYWORD ...)
 165 IMAGE-REGEXP should match all images files and is used to initialize the
 166 buffer local memory cache, see `x-symbol-image-init-memory-cache'.
 167
 168 Each KEYWORD looks like (REGEXP [FUNCTION] ARG...).  Image insertion
 169 commands matched by REGEXP are highlighted.  FUNCTION, which defaults to
 170 `x-symbol-image-default-file-name', is called with ARGs to get the file
 171 name of the corresponding image file.  If FUNCTION returns nil, the
 172 command is not highlighted.
 173
 174 Relative image file names are expanded in the directory returned by the
 175 function in the language access `x-symbol-LANG-master-directory', value
 176 nil means function `default-directory'.  Implicitly relative image file
 177 names are searched in a search path, see `x-symbol-image-use-remote'."
 178   (interactive)
 179   (save-excursion
 180     (x-symbol-image-init-memory-cache)
 181     (x-symbol-image-parse-region (point-min) (point-max) update-cache)))
 182
 183 ;;;###autoload
 184 (defun x-symbol-image-after-change-function (beg end old-len)
 185   ;; checkdoc-params: (beg end old-len)
 186   "Function in `after-change-functions' for image insertion commands."
 187   (if x-symbol-language
 188       (save-excursion
 189         (save-match-data
 190           (let ((zmacs-region-stays (and (boundp 'zmacs-region-stays)
 191                                          zmacs-region-stays)))
 192             (goto-char end)
 193             (end-of-line)
 194             (setq end (point))
 195             (goto-char beg)
 196             (beginning-of-line)
 197             (x-symbol-image-parse-region (point) end))))))
 198
 199 ;; Idea from package bib-cite: OK with a relatively small number of extents
 200 ;;;###autoload
 201 (defun x-symbol-image-delete-extents (beg end)
 202   "Delete x-symbol image extents covering text between BEG and END.
 203 See also `x-symbol-image-buffer-extents'."
 204   (let ((extents x-symbol-image-buffer-extents) extent)
 205     (setq x-symbol-image-buffer-extents nil)
 206     (if (featurep 'xemacs)
 207         (while extents
 208           (setq extent (pop extents))
 209           (if (or (extent-detached-p extent)
 210                   (and (> (extent-end-position extent) beg)
 211                        ;; If (beginning-of-line 2) instead (end-of-line) in
 212                        ;; `x-symbol-image-after-change-function': (> end...)
 213                        (>= end (extent-start-position extent))))
 214               (delete-extent extent)
 215             (push extent x-symbol-image-buffer-extents)))
 216       (while extents
 217         (setq extent (pop extents))
 218         (if (and (> (overlay-end extent) beg)
 219                  ;; If (beginning-of-line 2) instead (end-of-line) in
 220                  ;; `x-symbol-image-after-change-function': (> end...)
 221                  (>= end (overlay-start extent)))
 222             (delete-overlay extent)
 223           (push extent x-symbol-image-buffer-extents))))))
 224
 225
 226 ;;;===========================================================================
 227 ;;;  Main parse function
 228 ;;;===========================================================================
 229
 230 (defun x-symbol-image-parse-region (beg end &optional update-cache)
 231   "*Parse region between BEG and END to find image insertion commands.
 232 If optional UPDATE-CACHE is non-nil, use it instead of
 233 `x-symbol-image-update-cache' to determine whether to create new image
 234 cache files."
 235   (or update-cache (setq update-cache x-symbol-image-update-cache))
 236   (let ((modified (buffer-modified-p))
 237         (buffer-undo-list t) (inhibit-read-only t)
 238         buffer-file-name buffer-file-truename)
 239     (unwind-protect
 240         (let (;;(case-fold-search nil)
 241               (keywords (cdr (x-symbol-language-value
 242                               'x-symbol-LANG-image-keywords)))
 243               (cached-dirs (cons nil
 244                                  (mapcar 'file-name-as-directory
 245                                          (x-symbol-language-value
 246                                           'x-symbol-LANG-image-cached-dirs))))
 247               (master-dir (x-symbol-language-value
 248                            'x-symbol-LANG-master-directory))
 249               keyword matcher file-fn file-args
 250               file extent cache-elem extent-beg extent-end)
 251           (if master-dir (funcall master-dir))
 252           (x-symbol-image-delete-extents beg end)
 253           (while keywords
 254             (setq keyword (pop keywords)
 255                   matcher (car keyword)
 256                   file-fn #'x-symbol-image-default-file-name
 257                   file-args (cdr keyword))
 258             (if (functionp (car file-args))
 259                 (setq file-fn (pop file-args)))
 260             (goto-char beg)
 261             (while (setq extent-end (re-search-forward matcher end t))
 262               (setq extent-beg (match-beginning 0))
 263               (when (setq file (apply file-fn file-args))
 264                 (if (featurep 'xemacs)
 265                     (progn
 266                       (push (setq extent (make-extent extent-beg extent-end))
 267                             x-symbol-image-buffer-extents)
 268                       (set-extent-property extent 'start-open t)
 269                       (set-extent-property extent 'highlight t)
 270                       (set-extent-property extent 'x-symbol-image-file file)
 271                       (set-extent-property extent 'help-echo
 272                                            'x-symbol-image-help-echo)
 273                       (set-extent-property extent 'keymap
 274                                            x-symbol-image-highlight-map)
 275                       (set-extent-end-glyph
 276                        extent
 277                        (if (member (file-name-directory file) cached-dirs)
 278                            (if (setq cache-elem
 279                                      (cdr (assoc file x-symbol-image-memory-cache)))
 280                                (or (cdr cache-elem)
 281                                    (setcdr cache-elem (x-symbol-image-create-glyph
 282                                                        (car cache-elem) update-cache
 283                                                        (stringp
 284                                                         x-symbol-image-temp-name))))
 285                              x-symbol-image-design-glyph)
 286                          (if x-symbol-image-use-remote
 287                              (x-symbol-image-create-glyph
 288                               (expand-file-name file master-dir) update-cache)
 289                            x-symbol-image-remote-glyph))))
 290                   (push (setq extent (make-overlay extent-beg extent-end))
 291                         x-symbol-image-buffer-extents)
 292                   (overlay-put extent 'mouse-face 'highlight)
 293                   (overlay-put extent 'x-symbol-image-file file)
 294                   (overlay-put extent 'help-echo 'x-symbol-image-help-echo)
 295                   (overlay-put extent 'keymap x-symbol-image-highlight-map)
 296                   (overlay-put
 297                    extent 'after-string
 298                    (if (member (file-name-directory file) cached-dirs)
 299                        (if (setq cache-elem
 300                                  (cdr (assoc file x-symbol-image-memory-cache)))
 301                            (or (cdr cache-elem)
 302                                (setcdr cache-elem (x-symbol-image-create-glyph
 303                                                    (car cache-elem) update-cache
 304                                                    (stringp
 305                                                     x-symbol-image-temp-name))))
 306                          x-symbol-image-design-glyph)
 307                      (if x-symbol-image-use-remote
 308                          (x-symbol-image-create-glyph
 309                           (expand-file-name file master-dir) update-cache)
 310                        x-symbol-image-remote-glyph))))))))
 311       (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil)))))
 312
 313 (defun x-symbol-image-default-file-name (num &optional regexp extension)
 314   "Return image file name for last match.
 315 Default FUNCTION in language access `x-symbol-LANG-image-keywords', see
 316 `x-symbol-image-parse-buffer'.  Return text matched by the NUMth regexp
 317 group of the corresponding keyword regexp.  If REGEXP is non-nil and the
 318 file name does not match REGEXP, add EXTENSION to the file name."
 319   (let ((file (match-string num)))
 320     (if regexp
 321         (if (string-match regexp file) file (concat file extension))
 322       file)))
 323
 324
 325 ;;;===========================================================================
 326 ;;;  Create an (empty) memory cache
 327 ;;;===========================================================================
 328
 329 (defun x-symbol-image-init-memory-cache ()
 330   "Create an empty memory cache.
 331 Scan all directories in the searchpath and all subdirectories in the
 332 language access `x-symbol-LANG-image-cached-dirs' for files matched by
 333 IMAGE-REGEXP in the language access `x-symbol-LANG-image-keywords' to
 334 build `x-symbol-image-memory-cache' where all GLYPHs are nil."
 335   (let* ((master-dir (funcall (x-symbol-language-value
 336                                'x-symbol-LANG-master-directory)))
 337          (cached-dirs (x-symbol-language-value
 338                        'x-symbol-LANG-image-cached-dirs))
 339          (path (x-symbol-image-searchpath master-dir))
 340          (suffixes (car (x-symbol-language-value
 341                          'x-symbol-LANG-image-keywords)))
 342          implicit-dirs
 343          dirs dir)
 344     (setq x-symbol-image-memory-cache nil)
 345     (while cached-dirs
 346       (setq dir (file-name-as-directory (pop cached-dirs)))
 347       (if (or (string-match x-symbol-image-explicitly-relative-regexp dir)
 348               (file-name-absolute-p dir))
 349           (x-symbol-image-init-memory-cache-1
 350            (and master-dir (file-name-as-directory master-dir)) dir suffixes)
 351         (push dir implicit-dirs)))
 352     (while path
 353       (setq dir (pop path)
 354             dirs implicit-dirs)
 355       (while dirs
 356         (x-symbol-image-init-memory-cache-1 dir (pop dirs) suffixes))
 357       (x-symbol-image-init-memory-cache-1 dir nil suffixes))))
 358
 359 (defun x-symbol-image-init-memory-cache-1 (root subdir suffixes)
 360   "Initialize memory cache for image files in ROOT/SUBDIR with SUFFIXES."
 361   (let* ((dir (if subdir (expand-file-name subdir root) root))
 362          (files (and (file-accessible-directory-p dir)
 363                      (file-readable-p dir)
 364                      (x-symbol-directory-files dir nil suffixes t t)))
 365          file)
 366     (while files
 367       (setq file (pop files))
 368       (push (list (concat subdir file) (expand-file-name file dir))
 369             x-symbol-image-memory-cache))))
 370
 371 (defun x-symbol-image-searchpath (master-dir)
 372   "Return language dependent image searchpath in reverse order.
 373 Uses the language accesses `x-symbol-LANG-image-searchpath' and
 374 `x-symbol-LANG-master-directory' (via argument MASTER-DIR).  Include all
 375 subdirectories of elements in the image searchpath ending with \"//\",
 376 except symbolic links if `x-symbol-image-searchpath-follow-symlink' is
 377 nil."
 378   (let ((path (or (x-symbol-language-value 'x-symbol-LANG-image-searchpath)
 379                   '("./")))
 380         (dirs nil)
 381         dir truename slashslash)
 382     (setq x-symbol-image-all-dirs nil)
 383     (while path
 384       (setq dir (pop path)
 385             slashslash (and (> (length dir) 1)
 386                             (string-equal (substring dir -2) "//"))
 387             dir (file-name-as-directory
 388                  (expand-file-name (if slashslash (substring dir 0 -1) dir)
 389                                    master-dir))
 390             truename (file-truename dir))
 391       (unless (member truename x-symbol-image-all-dirs)
 392         (push truename x-symbol-image-all-dirs)
 393         (push dir dirs))
 394       (when slashslash
 395         (setq x-symbol-image-all-recursive-dirs (list truename))
 396         (setq dirs (x-symbol-image-searchpath-1 dir dirs))))
 397     dirs))
 398
 399 (defun x-symbol-image-searchpath-1 (dir dirs)
 400   "Add subdirectories of DIR to DIRS and return result."
 401   (and (file-accessible-directory-p dir)
 402        (file-readable-p dir)
 403        (let ((subs (x-symbol-directory-files dir t "[^.]" nil 'dirs))
 404              truename)
 405          (while subs
 406            (setq dir (pop subs))
 407            (when (or x-symbol-image-searchpath-follow-symlink
 408                      (not (file-symlink-p dir)))
 409              (setq dir (file-name-as-directory dir)
 410                    truename (file-truename dir))
 411              (unless (member truename x-symbol-image-all-recursive-dirs)
 412                (push truename x-symbol-image-all-recursive-dirs)
 413                (if (member truename x-symbol-image-all-dirs)
 414                    (setq dirs (x-symbol-image-searchpath-1 dir dirs))
 415                  (push truename x-symbol-image-all-dirs)
 416                  (setq dirs
 417                        (x-symbol-image-searchpath-1 dir (cons dir dirs)))))))))
 418   dirs)
 419
 420
 421 ;;;===========================================================================
 422 ;;;  Highlighting the image commands: main functions
 423 ;;;===========================================================================
 424
 425 (defun x-symbol-image-mouse-editor (event)
 426   (interactive "e")
 427   (let ((file (x-symbol-image-event-file event)))
 428     (if file
 429         (x-symbol-image-editor file (event-buffer event))
 430       (error "No image file to edit"))))
 431
 432 ;;;###autoload
 433 (defun x-symbol-image-editor (file &optional buffer)
 434   "Start image editor for the image file FILE used in BUFFER.
 435 If BUFFER is nil, just return string describing the command.  See
 436 `x-symbol-image-editor-alist' and `x-symbol-image-current-marker'."
 437   (interactive
 438    (list (read-file-name "Edit image design file for: "
 439                          (funcall (x-symbol-language-value
 440                                    'x-symbol-LANG-master-directory)))
 441          (current-buffer)))
 442   (let ((result (and file (x-symbol-match-in-alist
 443                            file x-symbol-image-editor-alist))))
 444     (and file buffer (setq file (x-symbol-image-active-file file buffer)))
 445     (if (and result file)
 446         (if (functionp (car result))
 447             (apply (car result) file buffer (cdr result))
 448           (setq result
 449                 (format (car result)
 450                         (if (cadr result)
 451                             (x-symbol-image-file-name file (cadr result))
 452                           file)))
 453           (if buffer
 454               (let ((default-directory (file-name-directory file)))
 455                 (shell-command result))
 456             result))
 457       (if buffer
 458           (if file
 459               (error "Do not know which image editor to use for %S" file)
 460             (error "Cannot use highlighted file"))))))
 461
 462 (defun x-symbol-image-highlight-menu (event)
 463   ;; checkdoc-params: (event)
 464   "Popup menu over the highlighted image insertion command.
 465 See `x-symbol-image-menu' and `x-symbol-image-editor-alist'."
 466   (interactive "e")
 467   (let ((file (x-symbol-image-event-file event)))
 468     (if file
 469         (popup-menu (x-symbol-image-active-file file (event-buffer event) t)))))
 470
 471 (defun x-symbol-image-help-echo (extent &optional object pos)
 472   "Return help echo for the EXTENT of the image insertion command.
 473 See variable `x-symbol-image-help-echo'."
 474   (if object (setq extent object))      ; Emacs
 475   (x-symbol-fancy-string
 476    (cons (format (car x-symbol-image-help-echo)
 477                  (x-symbol-image-editor (extent-property extent
 478                                                          'x-symbol-image-file)))
 479          (cdr x-symbol-image-help-echo))))
 480
 481
 482 ;;;===========================================================================
 483 ;;;  Get files which the image editor could work on
 484 ;;;===========================================================================
 485
 486 (defun x-symbol-image-file-name (file &optional extension dir)
 487   "Return a name deduced from the image file name FILE.
 488 Use EXTENSION as the new extension.  If DIR is non-nil, replace
 489 directory part by DIR.  With a non-nil `x-symbol-image-scale-method',
 490 the scale factor is deleted in the file name."
 491   (and file
 492        (let ((edit (file-name-sans-extension (file-name-nondirectory file))))
 493          (or dir (setq dir (file-name-directory file)))
 494          (setq file
 495                (concat (if (and x-symbol-image-scale-method
 496                                 (string-match x-symbol-image-scale-method edit))
 497                            (substring edit 0 (match-beginning 0))
 498                          edit)
 499                        extension))
 500          (if dir (expand-file-name file dir) file))))
 501
 502 (defun x-symbol-image-event-file (event)
 503   "Return image file name at position of mouse event EVENT."
 504   (and event
 505        (setq event (extent-at (if (featurep 'xemacs)
 506                                   (or (event-point event)
 507                                       (1- (event-closest-point event)))
 508                                 (posn-point (event-end event)))
 509                               (event-buffer event)
 510                               'x-symbol-image-file))
 511        (extent-property event 'x-symbol-image-file)))
 512
 513 (defun x-symbol-image-active-file (file buffer &optional menup)
 514   ;; checkdoc-params: (event)
 515   "Return the full name of the active image file FILE in BUFFER.
 516 If MENUP is non-nil, return menu specified by `x-symbol-image-menu'
 517 instead."
 518   (save-excursion
 519     (set-buffer buffer)
 520     (let ((master-dir (funcall (x-symbol-language-value
 521                                 'x-symbol-LANG-master-directory)))
 522           path)
 523       (if (or (string-match x-symbol-image-explicitly-relative-regexp file)
 524               (file-name-absolute-p file))
 525           (setq path (list (expand-file-name (file-name-directory file)
 526                                              master-dir))
 527                 file (file-name-nondirectory file))
 528         (setq path (x-symbol-image-searchpath master-dir)))
 529       (if menup
 530           (let ((menu (cdr x-symbol-image-menu))
 531                 dir full exists)
 532             (while path
 533               (setq dir (pop path)
 534                     full (expand-file-name file dir)
 535                     exists (file-exists-p full))
 536               (push (vector (if (featurep 'xemacs)
 537                                 (abbreviate-file-name dir t)
 538                               (abbreviate-file-name dir))
 539                             (list 'x-symbol-image-editor full buffer)
 540                             :active (if exists
 541                                         (file-readable-p full)
 542                                       (file-writable-p full))
 543                             :keys (and exists x-symbol-image-current-marker))
 544                     menu))
 545             (cons (format (car x-symbol-image-menu)
 546                           (x-symbol-image-editor file))
 547                   menu))
 548         (let (result full)
 549           (setq path (nreverse path))
 550           (while path
 551             (setq full (expand-file-name file (pop path)))
 552             (if (file-readable-p full)
 553                 (setq result full
 554                       path nil)
 555               (or result
 556                   (file-exists-p full)  ; i.e., not readable
 557                   (if (file-writable-p full) (setq result full)))))
 558           result)))))
 559
 560
 561 \f
 562 ;;;;##########################################################################
 563 ;;;;  Glyph creation via processes
 564 ;;;;##########################################################################
 565
 566
 567 ;; A stack is better than a FIFO queue since editing the current line should
 568 ;; have the highest priority.
 569 (defvar x-symbol-image-process-stack nil
 570   "Internal variable.  Stack of image conversion tasks.
 571 Each element looks like the value of `x-symbol-image-process-elem'.")
 572
 573 (defvar x-symbol-image-process-elem nil
 574   "Internal variable.  Current image conversion task element.
 575 It has the form (CACHE GLYPH COMMAND TEMP).  CACHE is the name of the
 576 image cache file, GLYPH is the glyph whose image will be defined by the
 577 finished image cache file.  COMMAND is the command which starts the
 578 process creating CACHE, see `x-symbol-image-converter'.  If TEMP is
 579 non-nil, the image cache file will be deleted directly after its
 580 usage.")
 581
 582
 583 ;;;===========================================================================
 584 ;;;  Main function for glyph creation
 585 ;;;===========================================================================
 586
 587 (defun x-symbol-image-create-glyph (file update-cache &optional temp)
 588   "Return a glyph for the image file FILE.
 589 Start a process to create a new image cache file.  If UPDATE-CACHE is
 590 non-nil, use it instead of `x-symbol-image-update-cache' to determine
 591 whether this is really necessary.  If optional TEMP is non-nil, allow
 592 the use of temporary cache files."
 593   (let ((infile (condition-case nil
 594                     (file-truename file)
 595                   (error nil)))
 596         outfile elem)
 597     (cond ((null infile) x-symbol-image-locked-glyph)
 598           ((null (file-readable-p infile))
 599            (if (and (null (file-exists-p infile))
 600                     (file-writable-p infile))
 601                x-symbol-image-design-glyph
 602              x-symbol-image-locked-glyph))
 603           ((null x-symbol-image-converter) x-symbol-image-junk-glyph)
 604           ((null (setq outfile
 605                        (x-symbol-image-cache-name
 606                         infile
 607                         ;; TODO: temp image files don't work with Emacs
 608                         (and temp (featurep 'xemacs) temp))))
 609            x-symbol-image-junk-glyph)
 610           ((and (stringp outfile)
 611                 (null (file-writable-p outfile)))
 612            x-symbol-image-junk-glyph)
 613           ((and (equal outfile (car x-symbol-image-process-elem))
 614                 (get-process x-symbol-image-process-name))
 615            (cadr x-symbol-image-process-elem))
 616           ((setq elem (assoc outfile x-symbol-image-process-stack))
 617            (prog1 (cadr elem)
 618              (x-symbol-image-process-stack)))
 619           (t
 620            (let* ((ofile (if (symbolp outfile)
 621                              (concat x-symbol-image-temp-name
 622                                      (cadr x-symbol-image-converter))
 623                            outfile))
 624                   (image (and (null (symbolp outfile))
 625                               (x-symbol-create-image
 626                                ofile (car x-symbol-image-converter))))
 627                   (glyph (x-symbol-make-glyph
 628                           (or image x-symbol-image-create-image))))
 629              (when (or (null image)
 630                        (eq update-cache t)
 631                        (and update-cache
 632                             (file-newer-than-file-p infile outfile)))
 633                (push (list ofile glyph
 634                            (list (cddr x-symbol-image-converter) infile ofile)
 635                            (symbolp outfile))
 636                      x-symbol-image-process-stack)
 637                (x-symbol-image-process-stack))
 638              glyph)))))
 639
 640
 641 ;;;===========================================================================
 642 ;;;  Compute name of file cache
 643 ;;;===========================================================================
 644
 645 (defun x-symbol-image-cache-name (infile temp)
 646   "Return the name of the image cache file for the image file INFILE.
 647 The directory part is determined by `x-symbol-image-cache-directories'.
 648 INFILE must be a fully expanded file name, the extension by
 649 `x-symbol-image-converter'.  Return value nil means, do not convert the
 650 image, use `x-symbol-image-junk-glyph' instead.  If optional TEMP is
 651 non-nil, allow the use of temporary cache files, in this case, t would
 652 be returned."
 653   (let* ((case-fold-search (eq system-type 'vax-vms))
 654          (indir (file-name-directory infile))
 655          (outdir (x-symbol-match-in-alist indir x-symbol-image-cache-directories
 656                                           nil t)))
 657     (if (symbolp outdir) (and outdir temp)
 658       (if (or (file-directory-p (setq outdir (expand-file-name outdir indir)))
 659               (condition-case nil
 660                   (progn (make-directory outdir t) t)
 661                 (error nil)))
 662           (x-symbol-image-file-name
 663            infile (cadr x-symbol-image-converter) outdir)))))
 664
 665
 666 ;;;===========================================================================
 667 ;;;  Process handling
 668 ;;;===========================================================================
 669
 670 (defun x-symbol-image-process-stack ()
 671   "Handle next task in variable `x-symbol-image-process-stack'."
 672   (if x-symbol-image-process-stack
 673       (let ((process (get-process x-symbol-image-process-name)))
 674         (unless (and process (eq (process-status process) 'run))
 675           (if process (delete-process process))
 676           (setq x-symbol-image-process-elem
 677                 (pop x-symbol-image-process-stack))
 678           (setq process (apply (caaddr x-symbol-image-process-elem)
 679                                (cdaddr x-symbol-image-process-elem)))
 680           (set-process-sentinel process 'x-symbol-image-process-sentinel)
 681           ))))
 682
 683 (defun x-symbol-image-convert-file (infile)
 684   "Put prefix before INFILE if necessary for \"convert\".
 685 Uses `x-symbol-image-convert-file-alist'.  Also put postfix \"[0]\"
 686 after INFILE to just use the first part of a multi-part image."
 687   (concat (x-symbol-match-in-alist infile x-symbol-image-convert-file-alist)
 688           infile
 689           "[0]"))
 690
 691 (defun x-symbol-image-start-convert-mono (infile outfile)
 692   "Start process convert INFILE to monochrome OUTFILE.
 693 Used as value in `x-symbol-image-converter'."
 694   (start-process x-symbol-image-process-name
 695                  (get-buffer-create x-symbol-image-process-buffer)
 696                  x-symbol-image-convert-program "+matte"
 697                  "-geometry" (format "%dx%d>" x-symbol-image-max-width
 698                                      x-symbol-image-max-height)
 699                  "-threshold" "190" "-monochrome"
 700                  (x-symbol-image-convert-file infile) outfile))
 701
 702 (defun x-symbol-image-start-convert-color (infile outfile)
 703   "Start process convert INFILE to OUTFILE with restricted colors.
 704 Used as value in `x-symbol-image-converter'."
 705   (start-process x-symbol-image-process-name
 706                  (get-buffer-create x-symbol-image-process-buffer)
 707                   x-symbol-image-convert-program "+matte"
 708                  "-geometry" (format "%dx%d>" x-symbol-image-max-width
 709                                      x-symbol-image-max-height)
 710                  "-sharpen" "58" "-colors" "4"
 711                  (x-symbol-image-convert-file infile) outfile))
 712
 713 (defun x-symbol-image-start-convert-truecolor (infile outfile)
 714   "Start process convert INFILE to OUTFILE using colors.
 715 Used as value in `x-symbol-image-converter'."
 716   (start-process x-symbol-image-process-name
 717                  (get-buffer-create x-symbol-image-process-buffer)
 718                  x-symbol-image-convert-program "+matte"
 719                  "-geometry" (format "%dx%d>" x-symbol-image-max-width
 720                                      x-symbol-image-max-height)
 721                  (x-symbol-image-convert-file infile) outfile))
 722
 723 (defun x-symbol-image-start-convert-mswindows (infile outfile)
 724   "Start process convert INFILE to OUTFILE using colors.
 725 Used as value in `x-symbol-image-converter'."
 726   (start-process x-symbol-image-process-name
 727                  (get-buffer-create x-symbol-image-process-buffer)
 728                  x-symbol-image-convert-program "+matte"
 729                  "-geometry" (format "%dx%d>" x-symbol-image-max-width
 730                                      x-symbol-image-max-height)
 731                  ;; for some reason [0] at the end of the file name does not
 732                  ;; work under ms-windows
 733                  (concat (x-symbol-match-in-alist
 734                           infile x-symbol-image-convert-file-alist)
 735                          infile)
 736                  outfile))
 737
 738 (defun x-symbol-image-start-convert-colormap (infile outfile)
 739   "Start process convert INFILE to OUTFILE using a colormap.
 740 Produce OUTFILE with `x-symbol-image-convert-colormap' or monochrome
 741 OUTFILE if `x-symbol-image-convert-mono-regexp' matches INFILE.  Used as
 742 value in `x-symbol-image-converter'."
 743   (if (or (and x-symbol-image-convert-mono-regexp
 744                (string-match x-symbol-image-convert-mono-regexp infile))
 745           (null x-symbol-image-convert-colormap))
 746       (x-symbol-image-start-convert-mono infile outfile)
 747     (start-process x-symbol-image-process-name
 748                    (get-buffer-create x-symbol-image-process-buffer)
 749                    x-symbol-image-convert-program "+matte"
 750                    "-geometry" (format "%dx%d>" x-symbol-image-max-width
 751                                        x-symbol-image-max-height)
 752                    "-map" x-symbol-image-convert-colormap
 753                    (x-symbol-image-convert-file infile) outfile)))
 754
 755 (defun x-symbol-image-process-sentinel (process event)
 756   "Set glyph image after process PROCESS has finished with value EVENT.
 757 Also look for more tasks in variable `x-symbol-image-process-stack'."
 758   (if (memq (process-status process) '(signal exit))
 759       (let ((buffer (process-buffer process)))
 760         (if (buffer-live-p buffer)
 761             ;; Don't follow info files, use some code from compile.el instead:
 762             ;; do not let cursor movement influence output placement
 763             (save-excursion
 764               (set-buffer buffer)
 765               (goto-char (point-max))
 766               (insert-before-markers (current-time-string) ": "
 767                                      (process-name process) " " event
 768                                      "\"" (car x-symbol-image-process-elem)
 769                                      (if (eq (process-status process) 'exit)
 770                                          "\" created\n"
 771                                        "\" failed\n"))))
 772         (x-symbol-set-glyph-image
 773          (cadr x-symbol-image-process-elem)
 774          (or (and (eq (process-status process) 'exit)
 775                   (x-symbol-create-image (car x-symbol-image-process-elem)
 776                                          (car x-symbol-image-converter)))
 777              x-symbol-image-broken-image))
 778         ;; TODO: in Emacs, we need `clear-image-cache' for some reason, in
 779         ;; older XEmacsen, we did need something, but it wasn't really
 780         ;; important, and I haven't noticed it anymore...
 781         (or (featurep 'xemacs)
 782             (and (boundp 'x-symbol-emacs-after-create-image-function)
 783                  (functionp x-symbol-emacs-after-create-image-function)
 784                  (funcall x-symbol-emacs-after-create-image-function)))
 785 ;;;     (redisplay-frame nil t)         ; doesn't work
 786 ;;;     (sit-for 0)                     ; does that work?
 787         (if (cadddr x-symbol-image-process-elem)
 788             (condition-case nil
 789                 (delete-file (car x-symbol-image-process-elem))
 790               (error nil)))
 791         (setq x-symbol-image-process-elem nil)
 792         (delete-process process)
 793         (x-symbol-image-process-stack))))
 794
 795 ;;; Local IspellPersDict: .ispell_xsymb
 796 ;;; x-symbol-image.el ends here