cgit.sxemacs.org Git - packages/blob - xemacs-packages/auctex/preview/prv-xemacs.el

   1 ;;; prv-xemacs.el --- XEmacs support for preview-latex
   2
   3 ;; Copyright (C) 2001, 02, 03, 04, 05,
   4 ;;               2006 Free Software Foundation, Inc.
   5
   6 ;; Author: David Kastrup
   7 ;; Keywords: convenience, tex, wp
   8
   9 ;; This file is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 3, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;
  27
  28 ;;; Code:
  29
  30 (require 'overlay)
  31 (require 'tex-site)
  32 (require 'tex)
  33 (require 'latex)
  34
  35 ;; Compatibility macros and functions.
  36
  37 (eval-when-compile
  38   (defvar preview-compatibility-macros nil
  39     "List of macros only present when compiling/loading uncompiled.")
  40
  41   (defmacro preview-defmacro (name &rest rest)
  42     (push
  43      (if (fboundp name)
  44          (cons name (symbol-function name))
  45        name)
  46      preview-compatibility-macros)
  47     `(eval-when-compile (defmacro ,name ,@rest)))
  48   (push 'preview-defmacro preview-compatibility-macros))
  49
  50 (preview-defmacro assoc-default (key alist test)
  51   `(cdr (assoc* ,key ,alist
  52                 :test #'(lambda(a b) (funcall ,test b a)))))
  53
  54 (preview-defmacro display-mm-height () '(device-mm-height))
  55 (preview-defmacro display-mm-width () '(device-mm-width))
  56 (preview-defmacro display-pixel-height () '(device-pixel-height))
  57 (preview-defmacro display-pixel-width () '(device-pixel-width))
  58 (preview-defmacro line-beginning-position () '(point-at-bol))
  59 (preview-defmacro line-end-position () '(point-at-eol))
  60
  61 ;; This is not quite the case, but unless we're playing with duplicable extents,
  62 ;; the two are equivalent in XEmacs.
  63 (preview-defmacro match-string-no-properties (&rest args)
  64   `(match-string ,@args))
  65
  66 (preview-defmacro face-attribute (face attr)
  67   (cond
  68     ((eq attr :height)
  69      `(round (/ (* ,(/ 720.0 25.4)
  70                    (face-height ,face)
  71                    (device-mm-height))
  72                 (device-pixel-height))))
  73     ((eq attr :foreground)
  74      `(face-foreground-instance ,face))
  75     ((eq attr :background)
  76      `(face-background-instance ,face))
  77     (t
  78      (error 'unimplemented (format "Don't know how to fake %s" attr)))))
  79
  80 (preview-defmacro make-temp-file (prefix dir-flag)
  81   (if (not dir-flag)
  82       (error 'unimplemented "Can only fake make-temp-file for directories"))
  83   `(let (file)
  84      (while (condition-case ()
  85                 (progn
  86                   (setq file
  87                         (make-temp-name ,prefix))
  88                   (make-directory file)
  89                   nil)
  90               (file-already-exists t))
  91        nil)
  92      file))
  93
  94 (preview-defmacro set-buffer-multibyte (multibyte)
  95   "Set the representation type of the current buffer.  If MULTIBYTE
  96 is non-`nil', the buffer becomes multibyte.  If MULTIBYTE is
  97 `nil', the buffer becomes unibyte.
  98
  99 Because XEmacs does not implement multibyte versus unibyte buffers
 100 per se (they just have encodings which may be unibyte or multibyte),
 101 this is only implemented for the `nil' case."
 102   (if (not multibyte)
 103       `(if (fboundp 'set-buffer-file-coding-system)
 104            (set-buffer-file-coding-system 'binary))
 105     (error 'unimplemented "`set-buffer-multibyte is only implemented for the binary case.")))
 106
 107 (preview-defmacro next-single-char-property-change (pos prop)
 108   "Return the position of next property change for a specific property.
 109 This is like `next-single-property-change', except that if no
 110 change is found before the end of the buffer, it returns
 111 \(point-max) rather than `nil'."
 112   `(or (next-single-property-change ,pos ,prop)
 113        (point-max)))
 114
 115 (preview-defmacro previous-single-char-property-change (pos prop)
 116   "Return the position of previous property change for a specific property.
 117 This is like `next-single-property-change', except that if no
 118 change is found before the end of the buffer, it returns
 119 \(point-min) rather than `nil'."
 120   `(or (previous-single-property-change ,pos ,prop)
 121        (point-min)))
 122
 123 (preview-defmacro with-temp-message (message &rest body)
 124   "Display MESSAGE temporarily if non-nil while BODY is evaluated.
 125 The original message is restored to the echo area after BODY has finished.
 126 The value returned is the value of the last form in BODY.
 127 MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
 128 If MESSAGE is nil, the echo area and message log buffer are unchanged.
 129 Use a MESSAGE of \"\" to temporarily clear the echo area.
 130
 131 The message is displayed with label `progress'; see `display-message'."
 132   (let ((current-message (make-symbol "current-message"))
 133         (temp-message (make-symbol "with-temp-message")))
 134     `(let ((,temp-message ,message)
 135            (,current-message))
 136        (unwind-protect
 137            (progn
 138              (when ,temp-message
 139                (setq ,current-message (current-message))
 140                (display-message 'progress ,temp-message))
 141              ,@body)
 142          (and ,temp-message
 143               (if ,current-message
 144                   (display-message 'progress ,current-message)
 145                 (message nil)))))))
 146
 147 (defun preview-mark-active ()
 148   "Return t if the mark is active."
 149   (and (mark)
 150        t))
 151
 152 (defvar preview-transparent-border)
 153
 154 ;; Images.
 155
 156 (defsubst preview-supports-image-type (imagetype)
 157   "Return whether IMAGETYPE is supported by XEmacs."
 158   (memq imagetype (image-instantiator-format-list)))
 159
 160 ;; TODO: Generalize this so we can create the fixed icons using it.
 161
 162 ;; Argh, dired breaks :file :(
 163 ;; This is a temporary kludge to get around that until a fixed dired
 164 ;; or a fixed XEmacs is released.
 165
 166 (defun preview-create-icon-1 (file type ascent)
 167   "Create an icon from FILE, image TYPE and ASCENT."
 168   (let ((glyph
 169          (make-glyph
 170           (vector type
 171                   :file file
 172                   :data (with-temp-buffer
 173                           (insert-file-contents-literally file)
 174                           (buffer-string))))))
 175     (set-glyph-baseline glyph ascent)
 176     glyph))
 177
 178 (defun preview-create-icon (file type ascent border)
 179   "Create an icon from FILE, image TYPE, ASCENT and BORDER."
 180   (list
 181    (preview-create-icon-1 file type ascent)
 182    file type ascent border))
 183
 184 (defvar preview-ascent-spec)
 185
 186 (put 'preview-filter-specs :type
 187      #'(lambda (keyword value &rest args)
 188          (if (preview-supports-image-type value)
 189              (let* (preview-ascent-spec
 190                     (glyph (make-glyph `[,value
 191                                          ,@(preview-filter-specs-1 args)])))
 192                (when preview-ascent-spec
 193                  (set-glyph-baseline glyph preview-ascent-spec))
 194                glyph)
 195            (throw 'preview-filter-specs nil))))
 196
 197 (put 'preview-filter-specs :ascent
 198      #'(lambda (keyword value &rest args)
 199          (setq preview-ascent-spec value)
 200          (preview-filter-specs-1 args)))
 201
 202 ;; No defcustom here: does not seem to make sense.
 203
 204 (defvar preview-tb-icon-specs
 205   '((:type xpm :file "prvtex-cap-up.xpm" :ascent 75)
 206     (:type xbm :file "prvtex24.xbm" :ascent 75)))
 207
 208 (defvar preview-tb-icon nil)
 209
 210 ;; Image frobbing.
 211
 212 (defun preview-add-urgentization (fun ov &rest rest)
 213   "Cause FUN (function call form) to be called when redisplayed.
 214 FUN must be a form with OV as first argument,
 215 REST as the remainder, returning T.  An alternative is to give
 216 what `preview-remove-urgentization' returns, this will reinstate
 217 the previous state."
 218   (set-extent-initial-redisplay-function
 219    ov
 220    (if (null rest)
 221        fun
 222      `(lambda (ov) (,fun ,ov ,@rest)))))
 223
 224 (defun preview-remove-urgentization (ov)
 225   "Undo urgentization of OV by `preview-add-urgentization'.
 226 Returns the old arguments to `preview-add-urgentization'
 227 if there was any urgentization."
 228   (prog1 (list (extent-property ov 'initial-redisplay-function) ov)
 229     (set-extent-initial-redisplay-function ov nil)))
 230
 231 (defsubst preview-icon-copy (icon)
 232   "Prepare for a later call of `preview-replace-active-icon'."
 233   icon)
 234
 235 (defsubst preview-replace-active-icon (ov replacement)
 236   "Replace the active Icon in OV by REPLACEMENT, another icon."
 237   (set-extent-property ov 'preview-image replacement)
 238   (add-text-properties 0 1 (list 'end-glyph (car replacement))
 239                        (car (extent-property ov 'strings)))
 240   (if (eq (extent-property ov 'preview-state) 'active)
 241       (set-extent-end-glyph ov (car replacement))))
 242
 243 (defvar preview-button-1 'button2)
 244 (defvar preview-button-2 'button3)
 245
 246 ;; The `x' and invisible junk is because XEmacs doesn't bother to insert
 247 ;; the extents of a zero-length string. Bah.
 248 ;; When this is fixed, we'll autodetect this case and use zero-length
 249 ;; strings where possible.
 250 (defmacro preview-make-clickable (&optional map glyph helpstring click1 click2)
 251   "Generate a clickable string or keymap.
 252 If MAP is non-nil, it specifies a keymap to add to, otherwise
 253 a new one is created.  If GLYPH is given, the result is made
 254 to display it wrapped in a string.  In that case,
 255 HELPSTRING is a format string with one or two %s specifiers
 256 for preview's clicks, displayed as a help-echo.  CLICK1 and CLICK2
 257 are functions to call on preview's clicks."
 258   `(let (,@(and glyph '((res (copy-sequence "x"))))
 259            (resmap ,(or map '(make-sparse-keymap))))
 260      ,@(if click1
 261            `((define-key resmap preview-button-1 ,click1)))
 262      ,@(if click2
 263            `((define-key resmap preview-button-2 ,click2)))
 264      ,@(if glyph
 265            `((add-text-properties
 266               0 1
 267               (list 'end-glyph ,glyph
 268                     'mouse-face 'highlight
 269               'preview-balloon-help
 270               ,(if (stringp helpstring)
 271                    (format helpstring preview-button-1 preview-button-2)
 272                  `(format ,helpstring preview-button-1 preview-button-2))
 273               'preview-keymap resmap)
 274               res)
 275              res)
 276          '(resmap))))
 277
 278 (defun preview-click-reroute (ov event)
 279   "If OV received a click EVENT on a glyph, reroute to special map."
 280   (let ((oldmap (extent-keymap ov)))
 281     (unwind-protect
 282         (progn
 283           (set-extent-keymap ov
 284                              (and (event-over-glyph-p event)
 285                                   (extent-property ov 'preview-keymap)))
 286           (dispatch-event event))
 287       (set-extent-keymap ov oldmap))))
 288
 289 (defun preview-reroute-map (ov)
 290   "Get rerouting keymap for OV for catching glyph clicks only."
 291   (let ((map (make-sparse-keymap))
 292         (fun `(lambda (event)
 293                 (interactive "e")
 294                 (preview-click-reroute ,ov event))))
 295     (define-key map preview-button-1 fun)
 296     (define-key map preview-button-2 fun)
 297     map))
 298
 299 (defun preview-balloon-reroute (ov)
 300   "Give balloon help only if over glyph of OV."
 301   (and (eq ov (event-glyph-extent (mouse-position-as-motion-event)))
 302        (extent-property ov 'preview-balloon-help)))
 303
 304 ;; Most of the changes to this are junking the use of overlays;
 305 ;; a bit of it is different, and there's a little extra paranoia.
 306
 307 ;; We also have to move the image from the begin to the end-glyph
 308 ;; whenever the extent is invisible because of a bug in XEmacs-21.4's
 309 ;; redisplay engine.
 310 (defun preview-toggle (ov &optional arg event)
 311   "Toggle visibility of preview overlay OV.
 312 ARG can be one of the following: t displays the overlay,
 313 nil displays the underlying text, and 'toggle toggles.
 314 If EVENT is given, it indicates the window where the event
 315 occured, either by being a mouse event or by directly being
 316 the window in question.  This may be used for cursor restoration
 317 purposes."
 318   (if (not (bufferp (extent-object ov)))
 319       (error 'wrong-type-argument ov))
 320   (let ((old-urgent (preview-remove-urgentization ov))
 321         (preview-state
 322          (if (if (eq arg 'toggle)
 323                  (not (eq (extent-property ov 'preview-state) 'active))
 324                arg)
 325              'active
 326            'inactive))
 327         (strings (extent-property ov 'strings)))
 328     (unless (eq (extent-property ov 'preview-state) 'disabled)
 329       (set-extent-property ov 'preview-state preview-state)
 330       (if (eq preview-state 'active)
 331           (progn
 332             (unless (extent-keymap ov)
 333               (set-extent-keymap ov (preview-reroute-map ov))
 334               (set-extent-property ov 'balloon-help #'preview-balloon-reroute))
 335             (set-extent-begin-glyph ov nil)
 336             (set-extent-end-glyph-layout ov 'text)
 337             (set-extent-end-glyph ov (get-text-property
 338                                       0 'end-glyph (car strings)))
 339             (set-extent-properties ov '(invisible t
 340                                         isearch-open-invisible ignore
 341                                         isearch-invisible t
 342                                         face nil))
 343             (dolist (prop '(preview-keymap
 344                             mouse-face preview-balloon-help))
 345               (set-extent-property ov prop
 346                                    (get-text-property 0 prop (car strings)))))
 347         (unless (cdr strings)
 348           (setcdr strings (preview-inactive-string ov)))
 349         (set-extent-end-glyph ov nil)
 350         (set-extent-begin-glyph-layout ov 'text)
 351         (set-extent-begin-glyph ov (get-text-property
 352                                     0 'end-glyph (cdr strings)))
 353         (set-extent-properties ov `(face preview-face
 354                                     mouse-face nil
 355                                     invisible nil
 356                                     isearch-invisible nil
 357                                     preview-keymap
 358                                     ,(get-text-property
 359                                      0 'preview-keymap (cdr strings))
 360                                     preview-balloon-help
 361                                     ,(get-text-property
 362                                      0 'preview-balloon-help (cdr strings)))))
 363       (if old-urgent
 364           (apply 'preview-add-urgentization old-urgent))))
 365   (if event
 366       (preview-restore-position
 367        ov
 368        (if (windowp event)
 369            event
 370          (event-window event)))))
 371
 372 ; Does FALLBACKS need to be implemented? Likely not.
 373 (defmacro preview-inherited-face-attribute (face attribute &optional
 374                                               fallbacks)
 375   "Fetch face attribute while adhering to inheritance.
 376 This searches FACE and all its ancestors for an ATTRIBUTE.
 377 FALLBACKS is unused."
 378   `(face-attribute ,face ,attribute))
 379
 380 (defun preview-get-colors ()
 381   "Return colors from the current display.
 382 Fetches the current screen colors and makes a vector
 383 of colors as numbers in the range 0..65535.
 384 Pure borderless black-on-white will return quadruple NIL."
 385   (let
 386       ((bg (color-instance-rgb-components (preview-inherited-face-attribute
 387              'preview-reference-face :background 'default)))
 388        (fg (color-instance-rgb-components (preview-inherited-face-attribute
 389                                            'preview-reference-face :foreground 'default))))
 390     (if (equal '(65535 65535 65535) bg)
 391         (setq bg nil))
 392     (if (equal '(0 0 0) fg)
 393         (setq fg nil))
 394     (vector bg fg nil nil)))
 395
 396 (defcustom preview-use-balloon-help nil
 397   "*Is balloon help enabled in preview-latex?"
 398   :group 'preview-appearance
 399   :type 'boolean)
 400
 401 (defcustom preview-buffer-recoding-alist
 402   (if (and (= emacs-major-version 21)
 403            (< emacs-minor-version 5))
 404       '((utf-8-unix . raw-text-unix)
 405         (utf-8-dos . raw-text-dos)
 406         (utf-8-mac . raw-text-mac)
 407         (utf-8 . raw-text)))
 408   "Translate buffer encodings into process encodings.
 409 TeX is sometimes bad dealing with 8bit encodings and rather bad
 410 dealing with multibyte encodings.  So the process encoding output
 411 might need to get temporarily reprocessed into the original byte
 412 stream before the buffer characters can be identified.  XEmacs
 413 21.4 is rather bad at preserving incomplete multibyte characters
 414 in that process.  This variable makes it possible to use a
 415 reconstructable coding system in the run buffer instead.  Specify
 416 an alist of base coding system names here, which you can get
 417 using
 418
 419   \(coding-system-name (coding-system-base buffer-file-coding-system))
 420
 421 in properly detected buffers."
 422   :group 'preview-latex
 423   :type '(repeat (cons symbol symbol)))
 424
 425 (defun preview-buffer-recode-system (base)
 426   "This is supposed to translate unrepresentable base encodings
 427  into something that can be used safely for byte streams in the
 428  run buffer.  XEmacs mule-ucs is so broken that this may be
 429  needed."
 430   (or (cdr (assq (coding-system-name base)
 431                  preview-buffer-recoding-alist))
 432       base))
 433
 434 (defun preview-mode-setup ()
 435   "Setup proper buffer hooks and behavior for previews."
 436   (set (make-local-variable 'desktop-save-buffer)
 437        #'desktop-buffer-preview-misc-data)
 438   (mapc #'make-local-hook
 439         '(pre-command-hook post-command-hook
 440           before-change-functions after-change-functions))
 441   (add-hook 'pre-command-hook #'preview-mark-point nil t)
 442   (add-hook 'post-command-hook #'preview-move-point nil t)
 443   (and preview-use-balloon-help
 444        (not (and (boundp 'balloon-help-mode)
 445                  balloon-help-mode))
 446        (balloon-help-minor-mode 1))
 447   (add-hook 'before-change-functions #'preview-handle-before-change nil t)
 448   (add-hook 'after-change-functions #'preview-handle-after-change nil t)
 449   (easy-menu-add preview-menu)
 450   (unless preview-tb-icon
 451     (setq preview-tb-icon (preview-filter-specs
 452                                        preview-tb-icon-specs))
 453     (when preview-tb-icon
 454       (setq preview-tb-icon
 455             (vector
 456              (list preview-tb-icon)
 457              #'preview-at-point
 458              t
 459              "Preview on/off at point"))))
 460 ;;; [Courtesy Stephen J. Turnbull, with some modifications
 461 ;;;  Message-ID: <87el9fglsj.fsf@tleepslib.sk.tsukuba.ac.jp>
 462 ;;;  I could not have figured this out for the world]
 463 ;;; Hm, there really ought to be a way to get the spec that would be
 464 ;;; instantiated in a given domain
 465   (when preview-tb-icon
 466     (let ((tb (cdadar (or (specifier-spec-list default-toolbar (current-buffer))
 467                           (specifier-spec-list default-toolbar 'global)))))
 468       (unless (member preview-tb-icon tb)
 469         (set-specifier default-toolbar
 470                        (append tb (list preview-tb-icon))
 471                        (current-buffer)))))
 472   (when buffer-file-name
 473     (let* ((filename (expand-file-name buffer-file-name))
 474            format-cons)
 475       (when (string-match (concat "\\." TeX-default-extension "\\'")
 476                           filename)
 477         (setq filename (substring filename 0 (match-beginning 0))))
 478       (setq format-cons (assoc filename preview-dumped-alist))
 479       (when (consp (cdr format-cons))
 480         (preview-unwatch-preamble format-cons)
 481         (preview-watch-preamble (current-buffer)
 482                                 (cadr format-cons)
 483                                 format-cons)))))
 484
 485 (defvar preview-marker (make-marker)
 486   "Marker for fake intangibility.")
 487
 488 (defvar preview-temporary-opened nil)
 489
 490 (defvar preview-last-location nil
 491   "Restored cursor position marker for reopened previews.")
 492 (make-variable-buffer-local 'preview-last-location)
 493
 494 (defun preview-mark-point ()
 495   "Mark position for fake intangibility."
 496   (when (eq (get-char-property (point) 'preview-state) 'active)
 497     (unless preview-last-location
 498       (setq preview-last-location (make-marker)))
 499     (set-marker preview-last-location (point))
 500     (set-marker preview-marker (point))
 501     (preview-move-point))
 502   (set-marker preview-marker (point)))
 503
 504 (defun preview-restore-position (ov window)
 505   "Tweak position after opening/closing preview.
 506 The treated overlay OV has been triggered in WINDOW.  This function
 507 records the original buffer position for reopening, or restores it
 508 after reopening.  Note that by using the mouse, you can open/close
 509 overlays not in the active window."
 510   (when (eq (extent-object ov) (window-buffer window))
 511     (with-current-buffer (extent-object ov)
 512       (if (eq (extent-property ov 'preview-state) 'active)
 513           (setq preview-last-location
 514                 (set-marker (or preview-last-location (make-marker))
 515                             (window-point window)))
 516         (when (and
 517                (markerp preview-last-location)
 518                (eq (extent-object ov) (marker-buffer preview-last-location))
 519                (< (extent-start-position ov) preview-last-location)
 520                (> (extent-end-position ov) preview-last-location))
 521           (set-window-point window preview-last-location))))))
 522
 523 (defun preview-move-point ()
 524   "Move point out of fake-intangible areas."
 525   (preview-check-changes)
 526   (let (newlist (pt (point)) distance)
 527     (setq preview-temporary-opened
 528           (dolist (ov preview-temporary-opened newlist)
 529             (and (extent-object ov)
 530                  (not (extent-detached-p ov))
 531                  (eq (extent-property ov 'preview-state) 'inactive)
 532                  (if (and (eq (extent-object ov) (current-buffer))
 533                           (or (<= pt (extent-start-position ov))
 534                               (>= pt (extent-end-position ov))))
 535                      (preview-toggle ov t)
 536                    (push ov newlist)))))
 537     (if (preview-auto-reveal-p
 538          preview-auto-reveal
 539          (setq distance
 540                (and (eq (marker-buffer preview-marker)
 541                         (current-buffer))
 542                     (- pt (marker-position preview-marker)))))
 543         (map-extents #'preview-open-overlay nil
 544                      pt pt nil nil 'preview-state 'active)
 545       (let (newpt)
 546         (while (setq newpt
 547                      (map-extents #'preview-skip-overlay nil
 548                                   pt pt (and distance (< distance 0)) nil
 549                                   'preview-state 'active))
 550           (setq pt newpt))
 551         (goto-char pt)))))
 552
 553 (defun preview-skip-overlay (ovr backward)
 554   "Skip point over OVR, BACKWARD is set if backwards.
 555 Returns new position or NIL."
 556   (if backward
 557       (and (> (extent-start-position ovr) (point-min))
 558            (1- (extent-start-position ovr)))
 559     (and (<= (extent-end-position ovr) (point-max))
 560          (> (extent-end-position ovr) (extent-start-position ovr))
 561          (extent-end-position ovr))))
 562
 563 (defun preview-open-overlay (ovr ignored)
 564   "Open the active preview OVR, IGNORED gets ignored.
 565 NIL is returned: this is for `map-extents'."
 566   (preview-toggle ovr)
 567   (push ovr preview-temporary-opened)
 568   nil)
 569
 570 (defadvice isearch-highlight (before preview protect disable)
 571   "Make isearch open preview text that's a search hit.
 572 Also make `query-replace' open preview text about to be replaced."
 573   (map-extents #'preview-open-overlay nil
 574                (ad-get-arg 0) (ad-get-arg 1)
 575                nil nil 'preview-state 'active))
 576
 577 (defcustom preview-query-replace-reveal t
 578   "*Make `isearch' and `query-replace' autoreveal previews."
 579   :group 'preview-appearance
 580   :type 'boolean
 581   :require 'preview
 582   :set (lambda (symbol value)
 583          (set-default symbol value)
 584          (if value
 585              (ad-enable-advice 'isearch-highlight 'before 'preview)
 586            (ad-disable-advice 'isearch-highlight 'before 'preview))
 587          (ad-activate 'isearch-highlight))
 588   :initialize #'custom-initialize-reset)
 589
 590 ;; Here is the beef: for best intuitiveness, we want to have
 591 ;; insertions be carried out as expected before iconized text
 592 ;; passages, but we want to insert *into* the overlay when not
 593 ;; iconized.  A preview that has become empty can not get content
 594 ;; again: we remove it.  A disabled preview needs no insert-in-front
 595 ;; handler.
 596
 597 (defvar preview-change-list nil
 598   "List of tentatively changed overlays.")
 599
 600 (defcustom preview-dump-threshold
 601   "^ *\\\\begin *{document}[ %]*$"
 602   "*Regexp denoting end of preamble.
 603 This is the location up to which preamble changes are considered
 604 to require redumping of a format."
 605   :group 'preview-latex
 606   :type 'string)
 607
 608 (defvar preview-preamble-format-cons nil
 609   "Where our preamble is supposed to end.")
 610 (make-variable-buffer-local 'preview-preamble-format-cons)
 611
 612 (defun preview-preamble-check-change (beg end)
 613   "Hook function for change hooks on preamble.
 614 Reacts to changes between BEG and END."
 615   (when (and (consp (cdr preview-preamble-format-cons))
 616              (cddr preview-preamble-format-cons)
 617              (< beg (cddr preview-preamble-format-cons)))
 618     (preview-unwatch-preamble preview-preamble-format-cons)
 619     (preview-format-kill preview-preamble-format-cons)
 620     (setcdr preview-preamble-format-cons t)))
 621
 622 (defun preview-watch-preamble (file command format-cons)
 623   "Set up a watch on master file FILE.
 624 FILE can be an associated buffer instead of a filename.
 625 COMMAND is the command that generated the format.
 626 FORMAT-CONS contains the format info for the main
 627 format dump handler."
 628   (let ((buffer (if (bufferp file)
 629                     file
 630                   (find-buffer-visiting file))) ov)
 631     (setq preview-preamble-format-cons nil)
 632     (setcdr
 633      format-cons
 634      (cons command
 635            (when buffer
 636              (with-current-buffer buffer
 637                (save-excursion
 638                  (save-restriction
 639                    (widen)
 640                    (goto-char (point-min))
 641                    (unless (re-search-forward preview-dump-threshold nil t)
 642                      (error "Can't find preamble of `%s'" file))
 643                    (setq preview-preamble-format-cons format-cons)
 644                    (point)))))))))
 645
 646 (defun preview-unwatch-preamble (format-cons)
 647   "Stop watching a format on FORMAT-CONS.
 648 The watch has been set up by `preview-watch-preamble'."
 649   (when (consp (cdr format-cons))
 650     (setcdr (cdr format-cons) nil)))
 651
 652 (defun preview-register-change (ov map-arg)
 653   "Register not yet changed OV for verification.
 654 This stores the old contents of the overlay in the
 655 `preview-prechange' property and puts the overlay into
 656 `preview-change-list' where `preview-check-changes' will
 657 find it at some later point of time.  MAP-ARG is ignored;
 658 it is usually generated by `map-extents'."
 659   (unless (extent-property ov 'preview-prechange)
 660     (if (eq (extent-property ov 'preview-state) 'disabled)
 661         (set-extent-property ov 'preview-prechange t)
 662       (set-extent-property ov
 663                            'preview-prechange
 664                            (save-restriction
 665                              (widen)
 666                              (buffer-substring-no-properties
 667                               (extent-start-position ov)
 668                               (extent-end-position ov)))))
 669     (push ov preview-change-list))
 670   nil)
 671
 672 (defun preview-check-changes ()
 673   "Check whether the contents under the overlay have changed.
 674 Disable it if that is the case.  Ignores text properties."
 675   (dolist (ov preview-change-list)
 676     (condition-case nil
 677         (with-current-buffer (extent-object ov)
 678           (let ((text (save-restriction
 679                         (widen)
 680                         (buffer-substring-no-properties
 681                          (extent-start-position ov)
 682                          (extent-end-position ov)))))
 683             (if (or (zerop (length text))
 684                     (extent-detached-p ov))
 685                 (preview-delete ov)
 686               (unless
 687                   (or (eq (extent-property ov 'preview-state) 'disabled)
 688                       (preview-relaxed-string=
 689                        text (extent-property ov 'preview-prechange)))
 690                 (preview-disable ov)))))
 691       (error nil))
 692     (set-extent-property ov 'preview-prechange nil))
 693   (setq preview-change-list nil))
 694
 695 (defun preview-handle-before-change (beg end)
 696   "Hook function for `before-change-functions'.
 697 Receives BEG and END, the affected region."
 698   (map-extents #'preview-register-change nil beg end
 699                nil nil 'preview-state)
 700   (preview-preamble-check-change beg end))
 701
 702 (defun preview-handle-after-change (beg end length)
 703   "Hook function for `after-change-functions'.
 704 Receives BEG and END, the affected region, and LENGTH
 705 of an insertion."
 706   (when (and preview-change-list
 707              (zerop length)
 708              (not (eq this-command 'undo)))
 709     (map-extents (lambda (ov maparg)
 710                    (set-extent-endpoints
 711                     ov maparg (extent-end-position ov))) nil
 712                     beg beg end 'start-in-region 'preview-state 'active)
 713     (map-extents (lambda (ov maparg)
 714                    (set-extent-endpoints
 715                     ov (extent-start-position ov) maparg)) nil
 716                     end end beg 'end-in-region 'preview-state 'active)))
 717
 718 (defun preview-import-image (image)
 719   "Convert the printable IMAGE rendition back to an image."
 720   (cond ((stringp image)
 721          (setq image (copy-sequence image))
 722          (add-text-properties 0 (length image)
 723                               '(face preview-face)
 724                               image)
 725          image)
 726         ((eq (car image) 'image)
 727          (let ((plist (cdr image)))
 728            (preview-create-icon-1
 729             (plist-get plist :file)
 730             (plist-get plist :type)
 731             (plist-get plist :ascent))))
 732         (t
 733          (preview-create-icon-1 (nth 0 image)
 734                                 (nth 1 image)
 735                                 (nth 2 image)))))
 736
 737 (provide 'prv-xemacs)
 738
 739 ;;; Local variables:
 740 ;;; eval: (put 'preview-defmacro 'lisp-indent-function 'defun)
 741 ;;; end:
 742
 743 ;;; prv-xemacs.el ends here