branch: externals/auctex
commit b21889e0f805ddaaea25317da2c872d90907d0c2
Author: Ikumi Keita <ik...@ikumi.que.jp>
Commit: Ikumi Keita <ik...@ikumi.que.jp>
Merge prv-emacs.el into preview.el.in
* preview.el.in: Merge all contents of prv-emacs.el.
* prv-emacs.el: Delete.
* Makefile.in:
* configure.ac:
Drop prv-emacs.el.
---
Makefile.in | 2 +-
configure.ac | 3 -
preview.el.in | 512 +++++++++++++++++++++++++++++++++++++++++++++++-
prv-emacs.el | 609 ----------------------------------------------------------
4 files changed, 511 insertions(+), 615 deletions(-)
diff --git a/Makefile.in b/Makefile.in
index 1037fe0..63234c1 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -177,7 +177,7 @@ STYLESRC = style/prosper.el \
STYLEELC = $(STYLESRC:.el=.elc)
ifeq (@preview_enabled@,yes)
- PREVIEWSRC = @PLAT_LISP@ preview.el
+ PREVIEWSRC = preview.el
PREVIEWELC = $(PREVIEWSRC:.el=.elc)
PREVIEWLATEX = $(MAKE) preview-latex.el
TEXMF = (cd latex ; $(MAKE) all)
diff --git a/configure.ac b/configure.ac
index 566378d..a31b049 100644
--- a/configure.ac
+++ b/configure.ac
@@ -55,8 +55,6 @@ AC_ARG_ENABLE(preview,
[preview_enabled="yes"])
AC_SUBST(preview_enabled)
-PLAT_LISP=prv-emacs.el
-
EMACS_PATH_LISPDIR
AC_MSG_CHECKING(what file to use for auctex startup)
AC_ARG_WITH(auctexstartfile,
@@ -92,7 +90,6 @@ texsitedir="${lispdir}"
AC_SUBST(auctexstartfile)
AC_SUBST(previewstartfile)
-AC_SUBST(PLAT_LISP)
AC_MSG_CHECKING([where the package lisp files go])
AC_ARG_WITH(packagelispdir,
diff --git a/preview.el.in b/preview.el.in
index 46fcd90..c14e490 100644
--- a/preview.el.in
+++ b/preview.el.in
@@ -55,8 +55,6 @@ preview-latex buffers will not survive across sessions.")))
preview-latex's bug reporting commands will probably not work.")))
(require 'info))
-(require 'prv-emacs)
-
(defgroup preview nil "Embed Preview images into LaTeX buffers."
:group 'AUCTeX
:prefix "preview-"
@@ -887,6 +885,10 @@ Pure borderless black-on-white will return an empty
string."
(and border
(format "--bd %d" (max 1 (round (/ (* res border) 72.0))))))))
+(defsubst preview-supports-image-type (imagetype)
+ "Check if IMAGETYPE is supported."
+ (image-type-available-p imagetype))
+
(defun preview-gs-dvips-process-setup ()
"Set up Dvips process for conversions via gs."
(unless (preview-supports-image-type preview-gs-image-type)
@@ -1198,6 +1200,26 @@ is located."
(push ov preview-gs-queue)))
t)
+(defsubst preview-icon-copy (icon)
+ "Prepare a later call of `preview-replace-active-icon'."
+
+ ;; This is just a GNU Emacs specific efficiency hack because it
+ ;; is easy to do. When porting, don't do anything complicated
+ ;; here, rather deliver just the unchanged icon and make
+ ;; `preview-replace-active-icon' do the necessary work of replacing
+ ;; the icon where it actually has been stored, probably
+ ;; in the car of the strings property of the overlay. This string
+ ;; might probably serve as a begin-glyph as well, in which case
+ ;; modifying the string in the strings property would change that
+ ;; glyph automatically.
+
+ (cons 'image (cdr icon)))
+
+(defsubst preview-replace-active-icon (ov replacement)
+ "Replace the active Icon in OV by REPLACEMENT, another icon."
+ (let ((img (overlay-get ov 'preview-image)))
+ (setcdr (car img) (cdar replacement))
+ (setcdr img (cdr replacement))))
(defun preview-gs-place (ov snippet box run-buffer tempdir ps-file _imagetype)
"Generate an image placeholder rendered over by Ghostscript.
@@ -1226,6 +1248,35 @@ for the file extension."
(defvar view-exit-action)
+(eval-and-compile
+ (defvar preview-button-1 [mouse-2])
+ (defvar preview-button-2 [mouse-3]))
+
+(defmacro preview-make-clickable (&optional map glyph helpstring click1 click2)
+ "Generate a clickable string or keymap.
+If MAP is non-nil, it specifies a keymap to add to, otherwise
+a new one is created. If GLYPH is given, the result is made
+to display it wrapped in a string. In that case,
+HELPSTRING is a format string with one or two %s specifiers
+for preview's clicks, displayed as a help-echo. CLICK1 and CLICK2
+are functions to call on preview's clicks."
+ `(let ((resmap ,(or map '(make-sparse-keymap))))
+ ,@(if click1
+ `((define-key resmap preview-button-1 ,click1)))
+ ,@(if click2
+ `((define-key resmap preview-button-2 ,click2)))
+ ,(if glyph
+ `(propertize
+ "x"
+ 'display ,glyph
+ 'mouse-face 'highlight
+ 'help-echo
+ ,(if (stringp helpstring)
+ (format helpstring preview-button-1 preview-button-2)
+ `(format ,helpstring preview-button-1 preview-button-2))
+ 'keymap resmap)
+ 'resmap)))
+
(defun preview-mouse-open-error (string)
"Display STRING in a new view buffer on click."
(let ((buff (get-buffer-create
@@ -1423,6 +1474,13 @@ recursively."
(symbol-value hook))
(t hook)))
+(defun preview-inherited-face-attribute (face attribute &optional inherit)
+ "Fetch face attribute while adhering to inheritance.
+This searches FACE for an ATTRIBUTE, using INHERIT
+for resolving unspecified or relative specs. See the fourth
+argument of function `face-attribute' for details."
+ (face-attribute face attribute nil inherit))
+
(defcustom preview-scale-function #'preview-scale-from-face
"*Scale factor for included previews.
This can be either a function to calculate the scale, or
@@ -1623,6 +1681,409 @@ considered unchanged."
:group 'preview-appearance
:type '(repeat function))
+(defcustom preview-transparent-color '(highlight :background)
+ "Color to appear transparent in previews.
+Set this to something unusual when using `preview-transparent-border',
+to the default background in most other cases."
+ :type '(radio (const :tag "None" nil)
+ (const :tag "Autodetect" t)
+ (color :tag "By name" :value "white")
+ (list :tag "Take from face"
+ :value (default :background)
+ (face)
+ (choice :tag "What to take"
+ (const :tag "Background" :value :background)
+ (const :tag "Foreground" :value :foreground))))
+ :group 'preview-appearance)
+
+;;; Note that the following default introduces a border only when
+;;; Emacs blinks politely when point is on an image (the tested
+;;; unrelated function was introduced at about the time image blinking
+;;; became tolerable).
+(defcustom preview-transparent-border (unless (fboundp 'posn-object-x-y) 1.5)
+ "Width of transparent border for previews in pt.
+Setting this to a numeric value will add a border of
+`preview-transparent-color' around images, and will turn
+the heuristic-mask setting of images to default to 't since
+then the borders are correctly detected even in case of
+palette operations. If the transparent color is something
+not present otherwise in the image, the cursor display
+will affect just this border. A width of 0 is interpreted
+by PostScript as meaning a single pixel, other widths are
+interpreted as PostScript points (1/72 of 1in)"
+ :group 'preview-appearance
+ :type '(choice (const :value nil :tag "No border")
+ (number :value 1.5 :tag "Border width in pt")))
+
+(defun preview-get-heuristic-mask ()
+ "Get heuristic-mask to use for previews.
+Consults `preview-transparent-color'."
+ (cond ((stringp preview-transparent-color)
+ (color-values preview-transparent-color))
+ ((or (not (consp preview-transparent-color))
+ (integerp (car preview-transparent-color)))
+ preview-transparent-color)
+ (t (color-values (preview-inherited-face-attribute
+ (nth 0 preview-transparent-color)
+ (nth 1 preview-transparent-color)
+ 'default)))))
+
+(defsubst preview-create-icon-1 (file type ascent border)
+ `(image
+ :file ,file
+ :type ,type
+ :ascent ,ascent
+ ,@(and border
+ '(:mask (heuristic t)))))
+
+(defun preview-create-icon (file type ascent border)
+ "Create an icon from FILE, image TYPE, ASCENT and BORDER."
+ (list
+ (preview-create-icon-1 file type ascent border)
+ file type ascent border))
+
+(put 'preview-filter-specs :type
+ (lambda (keyword value &rest args)
+ (if (image-type-available-p value)
+ `(image :type ,value
+ ,@(preview-filter-specs-1 args))
+ (throw 'preview-filter-specs nil))))
+
+(defun preview-import-image (image)
+ "Convert the printable IMAGE rendition back to an image."
+ (cond ((stringp image)
+ (propertize image 'face 'preview-face))
+ ((eq (car image) 'image)
+ image)
+ (t
+ (preview-create-icon-1 (nth 0 image)
+ (nth 1 image)
+ (nth 2 image)
+ (if (< (length image) 4)
+ (preview-get-heuristic-mask)
+ (nth 3 image))))))
+
+;; No defcustom here: does not seem to make sense.
+
+(defvar preview-tb-icon-specs
+ '((:type xpm :file "prvtex24.xpm")
+ (:type xbm :file "prvtex24.xbm")))
+
+(defvar preview-tb-icon nil)
+
+(defun preview-add-urgentization (fun ov &rest rest)
+ "Cause FUN (function call form) to be called when redisplayed.
+FUN must be a form with OV as first argument,
+REST as the remainder, returning T."
+ (let ((dispro (overlay-get ov 'display)))
+ (unless (eq (car dispro) 'when)
+ (overlay-put ov 'display `(when (,fun ,ov ,@rest) . ,dispro)))))
+
+(defun preview-remove-urgentization (ov)
+ "Undo urgentization of OV by `preview-add-urgentization'.
+Returns the old arguments to `preview-add-urgentization'
+if there was any urgentization."
+ (let ((dispro (overlay-get ov 'display)))
+ (when (eq (car-safe dispro) 'when)
+ (prog1
+ (car (cdr dispro))
+ (overlay-put ov 'display (cdr (cdr dispro)))))))
+
+(defvar preview-overlay nil)
+
+(put 'preview-overlay
+ 'modification-hooks
+ '(preview-handle-modification))
+
+(put 'preview-overlay
+ 'insert-in-front-hooks
+ '(preview-handle-insert-in-front))
+
+(put 'preview-overlay
+ 'insert-behind-hooks
+ '(preview-handle-insert-behind))
+
+;; We have to fake our way around atomicity.
+
+;; Here is the beef: for best intuitiveness, we want to have
+;; insertions be carried out as expected before iconized text
+;; passages, but we want to insert *into* the overlay when not
+;; iconized. A preview that has become empty can not get content
+;; again: we remove it. A disabled preview needs no insert-in-front
+;; handler.
+
+(defvar preview-change-list nil
+ "List of tentatively changed overlays.")
+
+(defcustom preview-dump-threshold
+ "^ *\\\\begin *{document}[ %]*$"
+ "*Regexp denoting end of preamble.
+This is the location up to which preamble changes are considered
+to require redumping of a format."
+ :group 'preview-latex
+ :type 'string)
+
+(defun preview-preamble-changed-function
+ (ov after-change beg end &optional length)
+ "Hook function for change hooks on preamble.
+See info node `(elisp) Overlay Properties' for
+definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
+ (let ((format-cons (overlay-get ov 'format-cons)))
+ (preview-unwatch-preamble format-cons)
+ (preview-format-kill format-cons)
+ (setcdr format-cons t)))
+
+(defun preview-watch-preamble (file command format-cons)
+ "Set up a watch on master file FILE.
+FILE can be an associated buffer instead of a filename.
+COMMAND is the command that generated the format.
+FORMAT-CONS contains the format info for the main
+format dump handler."
+ (let ((buffer (if (bufferp file)
+ file
+ (find-buffer-visiting file))) ov)
+ (setcdr
+ format-cons
+ (cons command
+ (when buffer
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (unless (re-search-forward preview-dump-threshold nil t)
+ (error "Can't find preamble of `%s'" file))
+ (setq ov (make-overlay (point-min) (point)))
+ (overlay-put ov 'format-cons format-cons)
+ (overlay-put ov 'insert-in-front-hooks
+ '(preview-preamble-changed-function))
+ (overlay-put ov 'modification-hooks
+ '(preview-preamble-changed-function))
+ ov))))))))
+
+(defun preview-unwatch-preamble (format-cons)
+ "Stop watching a format on FORMAT-CONS.
+The watch has been set up by `preview-watch-preamble'."
+ (when (consp (cdr format-cons))
+ (when (cddr format-cons)
+ (delete-overlay (cddr format-cons)))
+ (setcdr (cdr format-cons) nil)))
+
+(defun preview-register-change (ov)
+ "Register not yet changed OV for verification.
+This stores the old contents of the overlay in the
+`preview-prechange' property and puts the overlay into
+`preview-change-list' where `preview-check-changes' will
+find it at some later point of time."
+ (unless (overlay-get ov 'preview-prechange)
+ (if (eq (overlay-get ov 'preview-state) 'disabled)
+ (overlay-put ov 'preview-prechange t)
+ (overlay-put ov 'preview-prechange
+ (save-restriction
+ (widen)
+ (buffer-substring-no-properties
+ (overlay-start ov) (overlay-end ov)))))
+ (push ov preview-change-list)))
+
+(defun preview-check-changes ()
+ "Check whether the contents under the overlay have changed.
+Disable it if that is the case. Ignores text properties."
+ (dolist (ov preview-change-list)
+ (condition-case nil
+ (with-current-buffer (overlay-buffer ov)
+ (let ((text (save-restriction
+ (widen)
+ (buffer-substring-no-properties
+ (overlay-start ov) (overlay-end ov)))))
+ (if (zerop (length text))
+ (preview-delete ov)
+ (unless
+ (or (eq (overlay-get ov 'preview-state) 'disabled)
+ (preview-relaxed-string=
+ text (overlay-get ov 'preview-prechange)))
+ (overlay-put ov 'insert-in-front-hooks nil)
+ (overlay-put ov 'insert-behind-hooks nil)
+ (preview-disable ov)))))
+ (error nil))
+ (overlay-put ov 'preview-prechange nil))
+ (setq preview-change-list nil))
+
+(defun preview-handle-insert-in-front
+ (ov after-change beg end &optional length)
+ "Hook function for `insert-in-front-hooks' property.
+See info node `(elisp) Overlay Properties' for
+definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
+ (if after-change
+ (unless undo-in-progress
+ (if (eq (overlay-get ov 'preview-state) 'active)
+ (move-overlay ov end (overlay-end ov))))
+ (preview-register-change ov)))
+
+(defun preview-handle-insert-behind
+ (ov after-change beg end &optional length)
+ "Hook function for `insert-behind-hooks' property.
+This is needed in case `insert-before-markers' is used at the
+end of the overlay. See info node `(elisp) Overlay Properties'
+for definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
+ (if after-change
+ (unless undo-in-progress
+ (if (eq (overlay-get ov 'preview-state) 'active)
+ (move-overlay ov (overlay-start ov) beg)))
+ (preview-register-change ov)))
+
+(defun preview-handle-modification
+ (ov after-change beg end &optional length)
+ "Hook function for `modification-hooks' property.
+See info node `(elisp) Overlay Properties' for
+definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
+ (unless after-change
+ (preview-register-change ov)))
+
+(defun preview-toggle (ov &optional arg event)
+ "Toggle visibility of preview overlay OV.
+ARG can be one of the following: t displays the overlay,
+nil displays the underlying text, and 'toggle toggles.
+If EVENT is given, it indicates the window where the event
+occured, either by being a mouse event or by directly being
+the window in question. This may be used for cursor restoration
+purposes."
+ (let ((old-urgent (preview-remove-urgentization ov))
+ (preview-state
+ (if (if (eq arg 'toggle)
+ (null (eq (overlay-get ov 'preview-state) 'active))
+ arg)
+ 'active
+ 'inactive))
+ (strings (overlay-get ov 'strings)))
+ (unless (eq (overlay-get ov 'preview-state) 'disabled)
+ (overlay-put ov 'preview-state preview-state)
+ (if (eq preview-state 'active)
+ (progn
+ (overlay-put ov 'category 'preview-overlay)
+ (if (eq (overlay-start ov) (overlay-end ov))
+ (overlay-put ov 'before-string (car strings))
+ (dolist (prop '(display keymap mouse-face help-echo))
+ (overlay-put ov prop
+ (get-text-property 0 prop (car strings))))
+ (overlay-put ov 'before-string nil))
+ (overlay-put ov 'face nil))
+ (dolist (prop '(display keymap mouse-face help-echo))
+ (overlay-put ov prop nil))
+ (overlay-put ov 'face 'preview-face)
+ (unless (cdr strings)
+ (setcdr strings (preview-inactive-string ov)))
+ (overlay-put ov 'before-string (cdr strings)))
+ (if old-urgent
+ (apply 'preview-add-urgentization old-urgent))))
+ (if event
+ (preview-restore-position
+ ov
+ (if (windowp event)
+ event
+ (posn-window (event-start event))))))
+
+(defvar preview-marker (make-marker)
+ "Marker for fake intangibility.")
+
+(defvar preview-temporary-opened nil)
+
+(defvar preview-last-location nil
+ "Restored cursor position marker for reopened previews.")
+(make-variable-buffer-local 'preview-last-location)
+
+(defun preview-mark-point ()
+ "Mark position for fake intangibility."
+ (when (eq (get-char-property (point) 'preview-state) 'active)
+ (unless preview-last-location
+ (setq preview-last-location (make-marker)))
+ (set-marker preview-last-location (point))
+ (set-marker preview-marker (point))
+ (preview-move-point))
+ (set-marker preview-marker (point)))
+
+(defun preview-restore-position (ov window)
+ "Tweak position after opening/closing preview.
+The treated overlay OV has been triggered in WINDOW. This function
+records the original buffer position for reopening, or restores it
+after reopening. Note that by using the mouse, you can open/close
+overlays not in the active window."
+ (when (eq (overlay-buffer ov) (window-buffer window))
+ (with-current-buffer (overlay-buffer ov)
+ (if (eq (overlay-get ov 'preview-state) 'active)
+ (setq preview-last-location
+ (set-marker (or preview-last-location (make-marker))
+ (window-point window)))
+ (when (and
+ (markerp preview-last-location)
+ (eq (overlay-buffer ov) (marker-buffer preview-last-location))
+ (< (overlay-start ov) preview-last-location)
+ (> (overlay-end ov) preview-last-location))
+ (set-window-point window preview-last-location))))))
+
+(defun preview-move-point ()
+ "Move point out of fake-intangible areas."
+ (preview-check-changes)
+ (let* (newlist (pt (point)) (lst (overlays-at pt)) distance)
+ (setq preview-temporary-opened
+ (dolist (ov preview-temporary-opened newlist)
+ (and (overlay-buffer ov)
+ (eq (overlay-get ov 'preview-state) 'inactive)
+ (if (and (eq (overlay-buffer ov) (current-buffer))
+ (or (<= pt (overlay-start ov))
+ (>= pt (overlay-end ov))))
+ (preview-toggle ov t)
+ (push ov newlist)))))
+ (when lst
+ (if (or disable-point-adjustment
+ global-disable-point-adjustment
+ (preview-auto-reveal-p
+ preview-auto-reveal
+ (setq distance
+ (and (eq (marker-buffer preview-marker)
+ (current-buffer))
+ (- pt (marker-position preview-marker))))))
+ (preview-open-overlays lst)
+ (while lst
+ (setq lst
+ (if (and
+ (eq (overlay-get (car lst) 'preview-state) 'active)
+ (> pt (overlay-start (car lst))))
+ (overlays-at
+ (setq pt (if (and distance (< distance 0))
+ (overlay-start (car lst))
+ (overlay-end (car lst)))))
+ (cdr lst))))
+ (goto-char pt)))))
+
+(defun preview-open-overlays (list &optional pos)
+ "Open all previews in LIST, optionally restricted to enclosing POS."
+ (dolist (ovr list)
+ (when (and (eq (overlay-get ovr 'preview-state) 'active)
+ (or (null pos)
+ (and
+ (> pos (overlay-start ovr))
+ (< pos (overlay-end ovr)))))
+ (preview-toggle ovr)
+ (push ovr preview-temporary-opened))))
+
+(defadvice replace-highlight (before preview)
+ "Make `query-replace' open preview text about to be replaced."
+ (preview-open-overlays
+ (overlays-in (ad-get-arg 0) (ad-get-arg 1))))
+
+(defcustom preview-query-replace-reveal t
+ "*Make `query-replace' autoreveal previews."
+ :group 'preview-appearance
+ :type 'boolean
+ :require 'preview
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (if value
+ (ad-enable-advice 'replace-highlight 'before 'preview)
+ (ad-disable-advice 'replace-highlight 'before 'preview))
+ (ad-activate 'replace-highlight))
+ :initialize #'custom-initialize-reset)
+
(defun preview-relaxed-string= (&rest args)
"Check for functional equality of arguments.
The arguments ARGS are checked for equality by using
@@ -2581,6 +3042,32 @@ pp")
(customize-save-variable 'preview-TeX-style-dir nil)
(customize-set-variable 'preview-TeX-style-dir nil)))
+(defun preview-mode-setup ()
+ "Setup proper buffer hooks and behavior for previews."
+ (set (make-local-variable 'desktop-save-buffer)
+ #'desktop-buffer-preview-misc-data)
+ (add-hook 'pre-command-hook #'preview-mark-point nil t)
+ (add-hook 'post-command-hook #'preview-move-point nil t)
+ (unless preview-tb-icon
+ (setq preview-tb-icon (preview-filter-specs preview-tb-icon-specs)))
+ (when preview-tb-icon
+ (define-key LaTeX-mode-map [tool-bar preview]
+ `(menu-item "Preview at point" preview-at-point
+ :image ,preview-tb-icon
+ :help "Preview on/off at point")))
+ (when buffer-file-name
+ (let* ((filename (expand-file-name buffer-file-name))
+ format-cons)
+ (when (string-match (concat "\\." TeX-default-extension "\\'")
+ filename)
+ (setq filename (substring filename 0 (match-beginning 0))))
+ (setq format-cons (assoc filename preview-dumped-alist))
+ (when (consp (cdr format-cons))
+ (preview-unwatch-preamble format-cons)
+ (preview-watch-preamble (current-buffer)
+ (cadr format-cons)
+ format-cons)))))
+
;;;###autoload
(defun LaTeX-preview-setup ()
"Hook function for embedding the preview package into AUCTeX.
@@ -3152,6 +3639,27 @@ and `preview-colors' are set as given."
preview-resolution (nth 1 geometry)
preview-colors (nth 2 geometry)))
+(defun preview-get-colors ()
+ "Return colors from the current display.
+Fetches the current screen colors and makes a vector
+of colors as numbers in the range 0..65535.
+Pure borderless black-on-white will return triple NIL.
+The fourth value is the transparent border thickness."
+ (let
+ ((bg (color-values (preview-inherited-face-attribute
+ 'preview-reference-face :background 'default)))
+ (fg (color-values (preview-inherited-face-attribute
+ 'preview-reference-face :foreground 'default)))
+ (mask (preview-get-heuristic-mask)))
+ (if (equal '(65535 65535 65535) bg)
+ (setq bg nil))
+ (if (equal '(0 0 0) fg)
+ (setq fg nil))
+ (unless (and (numberp preview-transparent-border)
+ (consp mask) (integerp (car mask)))
+ (setq mask nil))
+ (vector bg fg mask preview-transparent-border)))
+
(defun preview-start-dvipng ()
"Start a DviPNG process.."
(let* ((file preview-gs-file)
diff --git a/prv-emacs.el b/prv-emacs.el
deleted file mode 100644
index 2d9a6ef..0000000
--- a/prv-emacs.el
+++ /dev/null
@@ -1,609 +0,0 @@
-;;; prv-emacs.el --- GNU Emacs specific code for preview.el
-
-;; Copyright (C) 2001-2005, 2018, 2019 Free Software Foundation, Inc.
-
-;; Author: David Kastrup
-;; Keywords: convenience, tex, wp
-
-;; This file is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; This file is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;;
-
-;;; Code:
-
-(require 'tex-site)
-(require 'tex)
-(require 'latex)
-
-;; Silence the compiler for functions:
-(declare-function preview-inherited-face-attribute "prv-emacs"
- (face attribute &optional inherit))
-(declare-function preview-filter-specs-1 "preview"
- (specs))
-(declare-function preview-format-kill "preview"
- (format-cons))
-(declare-function preview-delete "preview"
- (ovr &rest ignored))
-(declare-function preview-relaxed-string= "preview"
- (&rest args))
-(declare-function preview-disable "preview"
- (ovr))
-(declare-function preview-inactive-string "preview"
- (ov))
-(declare-function preview-filter-specs "preview"
- (spec-list))
-(declare-function preview-auto-reveal-p "preview"
- (mode distance))
-(declare-function desktop-buffer-preview-misc-data "preview"
- (&rest ignored))
-
-(defcustom preview-transparent-color '(highlight :background)
- "Color to appear transparent in previews.
-Set this to something unusual when using `preview-transparent-border',
-to the default background in most other cases."
- :type '(radio (const :tag "None" nil)
- (const :tag "Autodetect" t)
- (color :tag "By name" :value "white")
- (list :tag "Take from face"
- :value (default :background)
- (face)
- (choice :tag "What to take"
- (const :tag "Background" :value :background)
- (const :tag "Foreground" :value :foreground))))
- :group 'preview-appearance)
-
-;;; Note that the following default introduces a border only when
-;;; Emacs blinks politely when point is on an image (the tested
-;;; unrelated function was introduced at about the time image blinking
-;;; became tolerable).
-(defcustom preview-transparent-border (unless (fboundp 'posn-object-x-y) 1.5)
- "Width of transparent border for previews in pt.
-Setting this to a numeric value will add a border of
-`preview-transparent-color' around images, and will turn
-the heuristic-mask setting of images to default to 't since
-then the borders are correctly detected even in case of
-palette operations. If the transparent color is something
-not present otherwise in the image, the cursor display
-will affect just this border. A width of 0 is interpreted
-by PostScript as meaning a single pixel, other widths are
-interpreted as PostScript points (1/72 of 1in)"
- :group 'preview-appearance
- :type '(choice (const :value nil :tag "No border")
- (number :value 1.5 :tag "Border width in pt")))
-
-(defun preview-get-heuristic-mask ()
- "Get heuristic-mask to use for previews.
-Consults `preview-transparent-color'."
- (cond ((stringp preview-transparent-color)
- (color-values preview-transparent-color))
- ((or (not (consp preview-transparent-color))
- (integerp (car preview-transparent-color)))
- preview-transparent-color)
- (t (color-values (preview-inherited-face-attribute
- (nth 0 preview-transparent-color)
- (nth 1 preview-transparent-color)
- 'default)))))
-
-(defsubst preview-create-icon-1 (file type ascent border)
- `(image
- :file ,file
- :type ,type
- :ascent ,ascent
- ,@(and border
- '(:mask (heuristic t)))))
-
-(defun preview-create-icon (file type ascent border)
- "Create an icon from FILE, image TYPE, ASCENT and BORDER."
- (list
- (preview-create-icon-1 file type ascent border)
- file type ascent border))
-
-(put 'preview-filter-specs :type
- #'(lambda (keyword value &rest args)
- (if (image-type-available-p value)
- `(image :type ,value
- ,@(preview-filter-specs-1 args))
- (throw 'preview-filter-specs nil))))
-
-;; No defcustom here: does not seem to make sense.
-
-(defvar preview-tb-icon-specs
- '((:type xpm :file "prvtex24.xpm")
- (:type xbm :file "prvtex24.xbm")))
-
-(defvar preview-tb-icon nil)
-
-(defun preview-add-urgentization (fun ov &rest rest)
- "Cause FUN (function call form) to be called when redisplayed.
-FUN must be a form with OV as first argument,
-REST as the remainder, returning T."
- (let ((dispro (overlay-get ov 'display)))
- (unless (eq (car dispro) 'when)
- (overlay-put ov 'display `(when (,fun ,ov ,@rest) . ,dispro)))))
-
-(defun preview-remove-urgentization (ov)
- "Undo urgentization of OV by `preview-add-urgentization'.
-Returns the old arguments to `preview-add-urgentization'
-if there was any urgentization."
- (let ((dispro (overlay-get ov 'display)))
- (when (eq (car-safe dispro) 'when)
- (prog1
- (car (cdr dispro))
- (overlay-put ov 'display (cdr (cdr dispro)))))))
-
-(defsubst preview-icon-copy (icon)
- "Prepare a later call of `preview-replace-active-icon'."
-
- ;; This is just a GNU Emacs specific efficiency hack because it
- ;; is easy to do. When porting, don't do anything complicated
- ;; here, rather deliver just the unchanged icon and make
- ;; `preview-replace-active-icon' do the necessary work of replacing
- ;; the icon where it actually has been stored, probably
- ;; in the car of the strings property of the overlay. This string
- ;; might probably serve as a begin-glyph as well, in which case
- ;; modifying the string in the strings property would change that
- ;; glyph automatically.
-
- (cons 'image (cdr icon)))
-
-(defsubst preview-replace-active-icon (ov replacement)
- "Replace the active Icon in OV by REPLACEMENT, another icon."
- (let ((img (overlay-get ov 'preview-image)))
- (setcdr (car img) (cdar replacement))
- (setcdr img (cdr replacement))))
-
-(defvar preview-button-1 [mouse-2])
-(defvar preview-button-2 [mouse-3])
-
-(defmacro preview-make-clickable (&optional map glyph helpstring click1 click2)
- "Generate a clickable string or keymap.
-If MAP is non-nil, it specifies a keymap to add to, otherwise
-a new one is created. If GLYPH is given, the result is made
-to display it wrapped in a string. In that case,
-HELPSTRING is a format string with one or two %s specifiers
-for preview's clicks, displayed as a help-echo. CLICK1 and CLICK2
-are functions to call on preview's clicks."
- `(let ((resmap ,(or map '(make-sparse-keymap))))
- ,@(if click1
- `((define-key resmap preview-button-1 ,click1)))
- ,@(if click2
- `((define-key resmap preview-button-2 ,click2)))
- ,(if glyph
- `(propertize
- "x"
- 'display ,glyph
- 'mouse-face 'highlight
- 'help-echo
- ,(if (stringp helpstring)
- (format helpstring preview-button-1 preview-button-2)
- `(format ,helpstring preview-button-1 preview-button-2))
- 'keymap resmap)
- 'resmap)))
-
-(defvar preview-overlay nil)
-
-(put 'preview-overlay
- 'modification-hooks
- '(preview-handle-modification))
-
-(put 'preview-overlay
- 'insert-in-front-hooks
- '(preview-handle-insert-in-front))
-
-(put 'preview-overlay
- 'insert-behind-hooks
- '(preview-handle-insert-behind))
-
-;; We have to fake our way around atomicity.
-
-;; Here is the beef: for best intuitiveness, we want to have
-;; insertions be carried out as expected before iconized text
-;; passages, but we want to insert *into* the overlay when not
-;; iconized. A preview that has become empty can not get content
-;; again: we remove it. A disabled preview needs no insert-in-front
-;; handler.
-
-(defvar preview-change-list nil
- "List of tentatively changed overlays.")
-
-(defcustom preview-dump-threshold
- "^ *\\\\begin *{document}[ %]*$"
- "*Regexp denoting end of preamble.
-This is the location up to which preamble changes are considered
-to require redumping of a format."
- :group 'preview-latex
- :type 'string)
-
-(defun preview-preamble-changed-function
- (ov after-change beg end &optional length)
- "Hook function for change hooks on preamble.
-See info node `(elisp) Overlay Properties' for
-definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
- (let ((format-cons (overlay-get ov 'format-cons)))
- (preview-unwatch-preamble format-cons)
- (preview-format-kill format-cons)
- (setcdr format-cons t)))
-
-(defun preview-watch-preamble (file command format-cons)
- "Set up a watch on master file FILE.
-FILE can be an associated buffer instead of a filename.
-COMMAND is the command that generated the format.
-FORMAT-CONS contains the format info for the main
-format dump handler."
- (let ((buffer (if (bufferp file)
- file
- (find-buffer-visiting file))) ov)
- (setcdr
- format-cons
- (cons command
- (when buffer
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (unless (re-search-forward preview-dump-threshold nil t)
- (error "Can't find preamble of `%s'" file))
- (setq ov (make-overlay (point-min) (point)))
- (overlay-put ov 'format-cons format-cons)
- (overlay-put ov 'insert-in-front-hooks
- '(preview-preamble-changed-function))
- (overlay-put ov 'modification-hooks
- '(preview-preamble-changed-function))
- ov))))))))
-
-(defun preview-unwatch-preamble (format-cons)
- "Stop watching a format on FORMAT-CONS.
-The watch has been set up by `preview-watch-preamble'."
- (when (consp (cdr format-cons))
- (when (cddr format-cons)
- (delete-overlay (cddr format-cons)))
- (setcdr (cdr format-cons) nil)))
-
-(defun preview-register-change (ov)
- "Register not yet changed OV for verification.
-This stores the old contents of the overlay in the
-`preview-prechange' property and puts the overlay into
-`preview-change-list' where `preview-check-changes' will
-find it at some later point of time."
- (unless (overlay-get ov 'preview-prechange)
- (if (eq (overlay-get ov 'preview-state) 'disabled)
- (overlay-put ov 'preview-prechange t)
- (overlay-put ov 'preview-prechange
- (save-restriction
- (widen)
- (buffer-substring-no-properties
- (overlay-start ov) (overlay-end ov)))))
- (push ov preview-change-list)))
-
-(defun preview-check-changes ()
- "Check whether the contents under the overlay have changed.
-Disable it if that is the case. Ignores text properties."
- (dolist (ov preview-change-list)
- (condition-case nil
- (with-current-buffer (overlay-buffer ov)
- (let ((text (save-restriction
- (widen)
- (buffer-substring-no-properties
- (overlay-start ov) (overlay-end ov)))))
- (if (zerop (length text))
- (preview-delete ov)
- (unless
- (or (eq (overlay-get ov 'preview-state) 'disabled)
- (preview-relaxed-string=
- text (overlay-get ov 'preview-prechange)))
- (overlay-put ov 'insert-in-front-hooks nil)
- (overlay-put ov 'insert-behind-hooks nil)
- (preview-disable ov)))))
- (error nil))
- (overlay-put ov 'preview-prechange nil))
- (setq preview-change-list nil))
-
-(defun preview-handle-insert-in-front
- (ov after-change beg end &optional length)
- "Hook function for `insert-in-front-hooks' property.
-See info node `(elisp) Overlay Properties' for
-definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
- (if after-change
- (unless undo-in-progress
- (if (eq (overlay-get ov 'preview-state) 'active)
- (move-overlay ov end (overlay-end ov))))
- (preview-register-change ov)))
-
-(defun preview-handle-insert-behind
- (ov after-change beg end &optional length)
- "Hook function for `insert-behind-hooks' property.
-This is needed in case `insert-before-markers' is used at the
-end of the overlay. See info node `(elisp) Overlay Properties'
-for definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
- (if after-change
- (unless undo-in-progress
- (if (eq (overlay-get ov 'preview-state) 'active)
- (move-overlay ov (overlay-start ov) beg)))
- (preview-register-change ov)))
-
-(defun preview-handle-modification
- (ov after-change beg end &optional length)
- "Hook function for `modification-hooks' property.
-See info node `(elisp) Overlay Properties' for
-definition of OV, AFTER-CHANGE, BEG, END and LENGTH."
- (unless after-change
- (preview-register-change ov)))
-
-(defun preview-toggle (ov &optional arg event)
- "Toggle visibility of preview overlay OV.
-ARG can be one of the following: t displays the overlay,
-nil displays the underlying text, and 'toggle toggles.
-If EVENT is given, it indicates the window where the event
-occured, either by being a mouse event or by directly being
-the window in question. This may be used for cursor restoration
-purposes."
- (let ((old-urgent (preview-remove-urgentization ov))
- (preview-state
- (if (if (eq arg 'toggle)
- (null (eq (overlay-get ov 'preview-state) 'active))
- arg)
- 'active
- 'inactive))
- (strings (overlay-get ov 'strings)))
- (unless (eq (overlay-get ov 'preview-state) 'disabled)
- (overlay-put ov 'preview-state preview-state)
- (if (eq preview-state 'active)
- (progn
- (overlay-put ov 'category 'preview-overlay)
- (if (eq (overlay-start ov) (overlay-end ov))
- (overlay-put ov 'before-string (car strings))
- (dolist (prop '(display keymap mouse-face help-echo))
- (overlay-put ov prop
- (get-text-property 0 prop (car strings))))
- (overlay-put ov 'before-string nil))
- (overlay-put ov 'face nil))
- (dolist (prop '(display keymap mouse-face help-echo))
- (overlay-put ov prop nil))
- (overlay-put ov 'face 'preview-face)
- (unless (cdr strings)
- (setcdr strings (preview-inactive-string ov)))
- (overlay-put ov 'before-string (cdr strings)))
- (if old-urgent
- (apply 'preview-add-urgentization old-urgent))))
- (if event
- (preview-restore-position
- ov
- (if (windowp event)
- event
- (posn-window (event-start event))))))
-
-(defun preview-mode-setup ()
- "Setup proper buffer hooks and behavior for previews."
- (set (make-local-variable 'desktop-save-buffer)
- #'desktop-buffer-preview-misc-data)
- (add-hook 'pre-command-hook #'preview-mark-point nil t)
- (add-hook 'post-command-hook #'preview-move-point nil t)
- (easy-menu-add preview-menu LaTeX-mode-map)
- (unless preview-tb-icon
- (setq preview-tb-icon (preview-filter-specs preview-tb-icon-specs)))
- (when preview-tb-icon
- (define-key LaTeX-mode-map [tool-bar preview]
- `(menu-item "Preview at point" preview-at-point
- :image ,preview-tb-icon
- :help "Preview on/off at point")))
- (when buffer-file-name
- (let* ((filename (expand-file-name buffer-file-name))
- format-cons)
- (when (string-match (concat "\\." TeX-default-extension "\\'")
- filename)
- (setq filename (substring filename 0 (match-beginning 0))))
- (setq format-cons (assoc filename preview-dumped-alist))
- (when (consp (cdr format-cons))
- (preview-unwatch-preamble format-cons)
- (preview-watch-preamble (current-buffer)
- (cadr format-cons)
- format-cons)))))
-
-(defvar preview-marker (make-marker)
- "Marker for fake intangibility.")
-
-(defvar preview-temporary-opened nil)
-
-(defvar preview-last-location nil
- "Restored cursor position marker for reopened previews.")
-(make-variable-buffer-local 'preview-last-location)
-
-(defun preview-mark-point ()
- "Mark position for fake intangibility."
- (when (eq (get-char-property (point) 'preview-state) 'active)
- (unless preview-last-location
- (setq preview-last-location (make-marker)))
- (set-marker preview-last-location (point))
- (set-marker preview-marker (point))
- (preview-move-point))
- (set-marker preview-marker (point)))
-
-(defun preview-restore-position (ov window)
- "Tweak position after opening/closing preview.
-The treated overlay OV has been triggered in WINDOW. This function
-records the original buffer position for reopening, or restores it
-after reopening. Note that by using the mouse, you can open/close
-overlays not in the active window."
- (when (eq (overlay-buffer ov) (window-buffer window))
- (with-current-buffer (overlay-buffer ov)
- (if (eq (overlay-get ov 'preview-state) 'active)
- (setq preview-last-location
- (set-marker (or preview-last-location (make-marker))
- (window-point window)))
- (when (and
- (markerp preview-last-location)
- (eq (overlay-buffer ov) (marker-buffer preview-last-location))
- (< (overlay-start ov) preview-last-location)
- (> (overlay-end ov) preview-last-location))
- (set-window-point window preview-last-location))))))
-
-(defun preview-move-point ()
- "Move point out of fake-intangible areas."
- (preview-check-changes)
- (let* (newlist (pt (point)) (lst (overlays-at pt)) distance)
- (setq preview-temporary-opened
- (dolist (ov preview-temporary-opened newlist)
- (and (overlay-buffer ov)
- (eq (overlay-get ov 'preview-state) 'inactive)
- (if (and (eq (overlay-buffer ov) (current-buffer))
- (or (<= pt (overlay-start ov))
- (>= pt (overlay-end ov))))
- (preview-toggle ov t)
- (push ov newlist)))))
- (when lst
- (if (or disable-point-adjustment
- global-disable-point-adjustment
- (preview-auto-reveal-p
- preview-auto-reveal
- (setq distance
- (and (eq (marker-buffer preview-marker)
- (current-buffer))
- (- pt (marker-position preview-marker))))))
- (preview-open-overlays lst)
- (while lst
- (setq lst
- (if (and
- (eq (overlay-get (car lst) 'preview-state) 'active)
- (> pt (overlay-start (car lst))))
- (overlays-at
- (setq pt (if (and distance (< distance 0))
- (overlay-start (car lst))
- (overlay-end (car lst)))))
- (cdr lst))))
- (goto-char pt)))))
-
-(defun preview-open-overlays (list &optional pos)
- "Open all previews in LIST, optionally restricted to enclosing POS."
- (dolist (ovr list)
- (when (and (eq (overlay-get ovr 'preview-state) 'active)
- (or (null pos)
- (and
- (> pos (overlay-start ovr))
- (< pos (overlay-end ovr)))))
- (preview-toggle ovr)
- (push ovr preview-temporary-opened))))
-
-(defadvice replace-highlight (before preview)
- "Make `query-replace' open preview text about to be replaced."
- (preview-open-overlays
- (overlays-in (ad-get-arg 0) (ad-get-arg 1))))
-
-(defcustom preview-query-replace-reveal t
- "*Make `query-replace' autoreveal previews."
- :group 'preview-appearance
- :type 'boolean
- :require 'preview
- :set (lambda (symbol value)
- (set-default symbol value)
- (if value
- (ad-enable-advice 'replace-highlight 'before 'preview)
- (ad-disable-advice 'replace-highlight 'before 'preview))
- (ad-activate 'replace-highlight))
- :initialize #'custom-initialize-reset)
-
-;; Check whether the four-argument form of `face-attribute' exists.
-;; If not, we will get a `wrong-number-of-arguments' error thrown.
-;; Use `defun' instead of `defsubst' here so that the decision may be
-;; reverted at load time if you are compiling with one Emacs and using
-;; another.
-(if (condition-case nil
- (progn
- (face-attribute 'default :height nil nil)
- t)
- (wrong-number-of-arguments nil))
-
- (defun preview-inherited-face-attribute (face attribute &optional inherit)
- "Fetch face attribute while adhering to inheritance.
-This searches FACE for an ATTRIBUTE, using INHERIT
-for resolving unspecified or relative specs. See the fourth
-argument of function `face-attribute' for details."
- (face-attribute face attribute nil inherit))
-
- (defun preview-inherited-face-attribute (face attribute &optional inherit)
- "Fetch face attribute while adhering to inheritance.
-This searches FACE for an ATTRIBUTE. If it is 'unspecified,
-first inheritance is consulted (if INHERIT is non-NIL), then
-INHERIT is searched if it is a face or a list of faces.
-Relative specs are evaluated recursively until they get absolute or
-are not resolvable. Relative specs are float values."
- (let ((value (face-attribute face attribute)))
- (when inherit
- (setq inherit
- (append
- (let ((ancestors (face-attribute face :inherit)))
- (cond ((facep ancestors) (list ancestors))
- ((consp ancestors) ancestors)))
- (cond ((facep inherit) (list inherit))
- ((consp inherit) inherit)))))
- (cond ((null inherit) value)
- ((floatp value)
- (let ((avalue
- (preview-inherited-face-attribute
- (car inherit) attribute (or (cdr inherit) t))))
- (cond ((integerp avalue)
- (round (* avalue value)))
- ((floatp avalue)
- (* value avalue))
- (t value))))
- ((eq value 'unspecified)
- (preview-inherited-face-attribute
- (car inherit) attribute (or (cdr inherit) t)))
- (t value)))))
-
-(defun preview-get-colors ()
- "Return colors from the current display.
-Fetches the current screen colors and makes a vector
-of colors as numbers in the range 0..65535.
-Pure borderless black-on-white will return triple NIL.
-The fourth value is the transparent border thickness."
- (let
- ((bg (color-values (preview-inherited-face-attribute
- 'preview-reference-face :background 'default)))
- (fg (color-values (preview-inherited-face-attribute
- 'preview-reference-face :foreground 'default)))
- (mask (preview-get-heuristic-mask)))
- (if (equal '(65535 65535 65535) bg)
- (setq bg nil))
- (if (equal '(0 0 0) fg)
- (setq fg nil))
- (unless (and (numberp preview-transparent-border)
- (consp mask) (integerp (car mask)))
- (setq mask nil))
- (vector bg fg mask preview-transparent-border)))
-
-(defun preview-import-image (image)
- "Convert the printable IMAGE rendition back to an image."
- (cond ((stringp image)
- (propertize image 'face 'preview-face))
- ((eq (car image) 'image)
- image)
- (t
- (preview-create-icon-1 (nth 0 image)
- (nth 1 image)
- (nth 2 image)
- (if (< (length image) 4)
- (preview-get-heuristic-mask)
- (nth 3 image))))))
-
-(defsubst preview-supports-image-type (imagetype)
- "Check if IMAGETYPE is supported."
- (image-type-available-p imagetype))
-
-(provide 'prv-emacs)
-;;; prv-emacs.el ends here
