601 lines
21 KiB
EmacsLisp
601 lines
21 KiB
EmacsLisp
|
;;; prv-emacs.el --- GNU Emacs specific code for preview.el
|
||
|
|
||
|
;; Copyright (C) 2001, 02, 03, 04, 05 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)
|
||
|
|
||
|
(defvar preview-compatibility-macros nil
|
||
|
"List of macros only present when compiling/loading.")
|
||
|
|
||
|
(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))))))
|
||
|
|
||
|
(defsubst preview-buffer-recode-system (base)
|
||
|
"This is supposed to translate unrepresentable base encodings
|
||
|
into something that can be used safely for byte streams in the
|
||
|
run buffer. A noop for Emacs."
|
||
|
base)
|
||
|
|
||
|
(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)))
|
||
|
|
||
|
(defmacro preview-mark-active ()
|
||
|
"Return t if the mark is active."
|
||
|
'mark-active)
|
||
|
|
||
|
(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
|