430 lines
14 KiB
EmacsLisp
430 lines
14 KiB
EmacsLisp
|
;;; inlimg.el --- Display images inline
|
||
|
|
;;
|
||
|
|
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
|
||
|
|
;; Created: 2008-09-27
|
||
|
|
(defconst inlimg:version "0.7") ;; Version:
|
||
|
|
;; Last-Updated: 2009-07-14 Tue
|
||
|
|
;; URL:
|
||
|
|
;; Keywords:
|
||
|
|
;; Compatibility:
|
||
|
|
;;
|
||
|
|
;; Features that might be required by this library:
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;;
|
||
|
|
;; Display images inline. See `inlimg-mode' for more information.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Change log:
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;; This program 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 2, or
|
||
|
|
;; (at your option) any later version.
|
||
|
|
;;
|
||
|
|
;; This program 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 this program; see the file COPYING. If not, write to
|
||
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
|
||
|
|
;; Floor, Boston, MA 02110-1301, USA.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(eval-when-compile (require 'cl))
|
||
|
|
(eval-when-compile (require 'mumamo nil t))
|
||
|
|
(eval-when-compile (require 'ourcomments-util nil t))
|
||
|
|
|
||
|
|
(defvar inlimg-assoc-ext
|
||
|
|
'((png (".png"))
|
||
|
|
(gif (".gif"))
|
||
|
|
(tiff (".tiff"))
|
||
|
|
(jpeg (".jpg" ".jpeg"))
|
||
|
|
(xpm (".xpm"))
|
||
|
|
(xbm (".xbm"))
|
||
|
|
(pbm (".pbm"))))
|
||
|
|
|
||
|
|
(defvar inlimg-img-regexp nil)
|
||
|
|
(make-variable-buffer-local 'inlimg-img-regexp)
|
||
|
|
(put 'inlimg-img-regexp 'permanent-local t)
|
||
|
|
|
||
|
|
(defvar inlimg-img-regexp-html
|
||
|
|
(rx (or (and "<img"
|
||
|
|
(1+ space)
|
||
|
|
(0+ (1+ (not (any " <>")))
|
||
|
|
(1+ space))
|
||
|
|
"src=\""
|
||
|
|
(group (1+ (not (any "\""))))
|
||
|
|
"\""
|
||
|
|
(*? anything)
|
||
|
|
"/>")
|
||
|
|
(and "url("
|
||
|
|
?\"
|
||
|
|
(group (1+ (not (any "\)"))))
|
||
|
|
?\"
|
||
|
|
")"
|
||
|
|
)
|
||
|
|
(and "url("
|
||
|
|
(group (+? (not (any ")"))))
|
||
|
|
")"
|
||
|
|
)
|
||
|
|
)))
|
||
|
|
|
||
|
|
(defvar inlimg-img-regexp-org
|
||
|
|
(rx-to-string
|
||
|
|
`(and "[[file:"
|
||
|
|
(group (+? (not (any "\]")))
|
||
|
|
,(let ((types nil))
|
||
|
|
(dolist (typ image-types)
|
||
|
|
(when (image-type-available-p typ)
|
||
|
|
(dolist (ext (cadr (assoc typ inlimg-assoc-ext)))
|
||
|
|
(setq types (cons ext types)))))
|
||
|
|
(cons 'or types)))
|
||
|
|
"]"
|
||
|
|
(optional "["
|
||
|
|
(+? (not (any "\]")))
|
||
|
|
"]")
|
||
|
|
"]"
|
||
|
|
)))
|
||
|
|
|
||
|
|
(defconst inlimg-modes-img-values
|
||
|
|
'(
|
||
|
|
(html-mode inlimg-img-regexp-html)
|
||
|
|
(org-mode inlimg-img-regexp-org)
|
||
|
|
))
|
||
|
|
|
||
|
|
(defun inlimg-img-spec-p (spec)
|
||
|
|
(assoc spec inlimg-modes-img-values))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defgroup inlimg nil
|
||
|
|
"Customization group for inlimg."
|
||
|
|
:group 'nxhtml)
|
||
|
|
|
||
|
|
(defcustom inlimg-margins '(50 . 5)
|
||
|
|
"Margins when displaying image."
|
||
|
|
:type '(cons (integer :tag "Left margin")
|
||
|
|
(integer :tag "Top margin"))
|
||
|
|
:set (lambda (sym val)
|
||
|
|
(set-default sym val)
|
||
|
|
(when (fboundp 'inlimg-update-all-buffers)
|
||
|
|
(inlimg-update-all-buffers)))
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(defcustom inlimg-slice '(0 0 400 100)
|
||
|
|
"How to slice images."
|
||
|
|
:type '(choice (const :tag "Show whole images" nil)
|
||
|
|
(list :tag "Show slice of image"
|
||
|
|
(integer :tag "Top")
|
||
|
|
(integer :tag "Left")
|
||
|
|
(integer :tag "Width")
|
||
|
|
(integer :tag "Height")))
|
||
|
|
:set (lambda (sym val)
|
||
|
|
(set-default sym val)
|
||
|
|
(when (fboundp 'inlimg-update-all-buffers)
|
||
|
|
(inlimg-update-all-buffers)))
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(define-widget 'inlimg-spec-widget 'symbol
|
||
|
|
"An inline image specification."
|
||
|
|
:complete-function (lambda ()
|
||
|
|
(interactive)
|
||
|
|
(lisp-complete-symbol 'inlimg-img-spec-p))
|
||
|
|
:prompt-match 'inlimg-img-spec-p
|
||
|
|
:prompt-history 'widget-function-prompt-value-history
|
||
|
|
:match-alternatives '(inlimg-img-spec-p)
|
||
|
|
:validate (lambda (widget)
|
||
|
|
(unless (inlimg-img-spec-p (widget-value widget))
|
||
|
|
(widget-put widget :error (format "Invalid function: %S"
|
||
|
|
(widget-value widget)))
|
||
|
|
widget))
|
||
|
|
:value 'org-mode
|
||
|
|
:tag "Inlimg image values spec name")
|
||
|
|
|
||
|
|
;; (customize-option 'inlimg-mode-specs)
|
||
|
|
(defcustom inlimg-mode-specs
|
||
|
|
'(
|
||
|
|
(xml-mode html-mode)
|
||
|
|
(sgml-mode html-mode)
|
||
|
|
(nxml-mode html-mode)
|
||
|
|
(php-mode html-mode)
|
||
|
|
(css-mode html-mode)
|
||
|
|
)
|
||
|
|
"Equivalent mode for image tag search.
|
||
|
|
Note that derived modes \(see info) are recognized by default.
|
||
|
|
|
||
|
|
To add new image tag patterns modify `inlimg-modes-img-values'."
|
||
|
|
:type '(repeat
|
||
|
|
(list (major-mode-function :tag "Major mode")
|
||
|
|
(inlimg-spec-widget :tag "Use tags as specified in")))
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(defface inlimg-img-tag '((t :inherit 'lazy-highlight))
|
||
|
|
"Face added to img tag when displaying image."
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(defface inlimg-img-remote '((t :inherit 'isearch-fail))
|
||
|
|
"Face used for notes telling image is remote."
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(defface inlimg-img-missing '((t :inherit 'trailing-whitespace))
|
||
|
|
"Face used for notes telling image is missing."
|
||
|
|
:group 'inlimg)
|
||
|
|
|
||
|
|
(defvar inlimg-img-keymap
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
(define-key map [(control ?c) ?+] 'inlimg-toggle-display)
|
||
|
|
(define-key map [(control ?c) ?%] 'inlimg-toggle-slicing)
|
||
|
|
map)
|
||
|
|
"Keymap on image overlay.")
|
||
|
|
|
||
|
|
(eval-after-load 'gimp
|
||
|
|
'(gimp-add-point-bindings inlimg-img-keymap))
|
||
|
|
|
||
|
|
(defsubst inlimg-ovl-p (ovl)
|
||
|
|
"Return non-nil if OVL is an inlimg image overlay."
|
||
|
|
(overlay-get ovl 'inlimg-img))
|
||
|
|
|
||
|
|
(defun inlimg-ovl-valid-p (ovl)
|
||
|
|
(and (overlay-get ovl 'inlimg-img)
|
||
|
|
inlimg-img-regexp
|
||
|
|
(save-match-data
|
||
|
|
(let ((here (point)))
|
||
|
|
(goto-char (overlay-start ovl))
|
||
|
|
(prog1
|
||
|
|
(looking-at (symbol-value inlimg-img-regexp))
|
||
|
|
(goto-char here))))))
|
||
|
|
|
||
|
|
(defun inlimg-next (pt display-image)
|
||
|
|
"Display or hide next image after point PT.
|
||
|
|
If DISPLAY-IMAGE is non-nil then display image, otherwise hide it.
|
||
|
|
|
||
|
|
Return non-nil if an img tag was found."
|
||
|
|
(when inlimg-img-regexp
|
||
|
|
(let (src dir beg end img ovl remote beg-face)
|
||
|
|
(goto-char pt)
|
||
|
|
(save-match-data
|
||
|
|
(when (re-search-forward (symbol-value inlimg-img-regexp) nil t)
|
||
|
|
(setq src (or (match-string-no-properties 1)
|
||
|
|
(match-string-no-properties 2)
|
||
|
|
(match-string-no-properties 3)))
|
||
|
|
(setq beg (match-beginning 0))
|
||
|
|
(setq beg-face (get-text-property beg 'face))
|
||
|
|
(setq remote (string-match "^https?://" src))
|
||
|
|
(setq end (- (line-end-position) 0))
|
||
|
|
(setq ovl (catch 'old-ovl
|
||
|
|
(dolist (ovl (overlays-at beg))
|
||
|
|
(when (inlimg-ovl-p ovl)
|
||
|
|
(throw 'old-ovl ovl)))
|
||
|
|
nil))
|
||
|
|
(unless ovl
|
||
|
|
(setq ovl (make-overlay beg end))
|
||
|
|
(overlay-put ovl 'inlimg-img t)
|
||
|
|
(overlay-put ovl 'priority 100)
|
||
|
|
(overlay-put ovl 'face 'inlimg-img-tag)
|
||
|
|
(overlay-put ovl 'keymap inlimg-img-keymap))
|
||
|
|
(overlay-put ovl 'image-file src)
|
||
|
|
(overlay-put ovl 'inlimg-slice inlimg-slice)
|
||
|
|
(if display-image
|
||
|
|
(unless (memq beg-face '(font-lock-comment-face font-lock-string-face))
|
||
|
|
(unless remote
|
||
|
|
(setq dir (if (buffer-file-name)
|
||
|
|
(file-name-directory (buffer-file-name))
|
||
|
|
default-directory))
|
||
|
|
(setq src (expand-file-name src dir)))
|
||
|
|
(if (or remote (not (file-exists-p src)))
|
||
|
|
(setq img (propertize
|
||
|
|
(if remote " Image is on the web " " Image not found ")
|
||
|
|
'face (if remote 'inlimg-img-remote 'inlimg-img-missing)))
|
||
|
|
(setq img (create-image src nil nil
|
||
|
|
:relief 5
|
||
|
|
:margin inlimg-margins))
|
||
|
|
(setq img (inlimg-slice-img img inlimg-slice)))
|
||
|
|
(let ((str (copy-sequence "\nX")))
|
||
|
|
(setq str (propertize str 'face 'inlimg-img-tag))
|
||
|
|
(put-text-property 1 2 'display img str)
|
||
|
|
(overlay-put ovl 'after-string str)))
|
||
|
|
(overlay-put ovl 'after-string nil))))
|
||
|
|
ovl)))
|
||
|
|
|
||
|
|
(defun inlimg-slice-img (img slice)
|
||
|
|
(if (not slice)
|
||
|
|
img
|
||
|
|
(let* ((sizes (image-size img t))
|
||
|
|
(width (car sizes))
|
||
|
|
(height (cdr sizes))
|
||
|
|
(sl-left (nth 0 slice))
|
||
|
|
(sl-top (nth 1 slice))
|
||
|
|
(sl-width (nth 2 slice))
|
||
|
|
(sl-height (nth 3 slice)))
|
||
|
|
(when (> sl-left width) (setq sl-left 0))
|
||
|
|
(when (> (+ sl-left sl-width) width) (setq sl-width (- width sl-left)))
|
||
|
|
(when (> sl-top height) (setq sl-top 0))
|
||
|
|
(when (> (+ sl-top sl-height) height) (setq sl-height (- height sl-top)))
|
||
|
|
(setq img (list img))
|
||
|
|
(setq img (cons (append '(slice)
|
||
|
|
slice
|
||
|
|
(list sl-top sl-left sl-width sl-height)
|
||
|
|
nil)
|
||
|
|
img)))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode inlimg-mode
|
||
|
|
"Display images inline.
|
||
|
|
Search buffer for image tags. Display found images.
|
||
|
|
|
||
|
|
Image tags are setup per major mode in `inlimg-mode-specs'.
|
||
|
|
|
||
|
|
Images are displayed on a line below the tag referencing them.
|
||
|
|
The whole image or a slice of it may be displayed, see
|
||
|
|
`inlimg-slice'. Margins relative text are specified in
|
||
|
|
`inlimg-margins'.
|
||
|
|
|
||
|
|
See also the commands `inlimg-toggle-display' and
|
||
|
|
`inlimg-toggle-slicing'.
|
||
|
|
|
||
|
|
Note: This minor mode uses `font-lock-mode'."
|
||
|
|
:keymap nil
|
||
|
|
:group 'inlimg
|
||
|
|
(if inlimg-mode
|
||
|
|
(progn
|
||
|
|
(let ((major-mode (or (and (boundp 'mumamo-multi-major-mode)
|
||
|
|
mumamo-multi-major-mode
|
||
|
|
(fboundp 'mumamo-main-major-mode)
|
||
|
|
(mumamo-main-major-mode))
|
||
|
|
major-mode)))
|
||
|
|
(inlimg-get-buffer-img-values)
|
||
|
|
(unless inlimg-img-regexp
|
||
|
|
(message "inlim-mode: No image spec, can't do anything"))
|
||
|
|
(add-hook 'font-lock-mode-hook 'inlimg-on-font-lock-off))
|
||
|
|
(inlimg-font-lock t))
|
||
|
|
(inlimg-font-lock nil)
|
||
|
|
(inlimg-delete-overlays)))
|
||
|
|
(put 'inlimg-mode 'permanent-local t)
|
||
|
|
|
||
|
|
(defun inlimg-delete-overlays ()
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(let (ovl)
|
||
|
|
(dolist (ovl (overlays-in (point-min) (point-max)))
|
||
|
|
(when (inlimg-ovl-p ovl)
|
||
|
|
(delete-overlay ovl))))))
|
||
|
|
|
||
|
|
(defun inlimg-get-buffer-img-values ()
|
||
|
|
(let* (rec
|
||
|
|
(spec (or (catch 'spec
|
||
|
|
(dolist (rec inlimg-mode-specs)
|
||
|
|
(when (derived-mode-p (car rec))
|
||
|
|
(throw 'spec (nth 1 rec)))))
|
||
|
|
major-mode))
|
||
|
|
(values (when spec (nth 1 (assoc spec inlimg-modes-img-values))))
|
||
|
|
)
|
||
|
|
(setq inlimg-img-regexp values)
|
||
|
|
))
|
||
|
|
|
||
|
|
(defun inlimg--global-turn-on ()
|
||
|
|
(inlimg-get-buffer-img-values)
|
||
|
|
(when inlimg-img-regexp
|
||
|
|
(inlimg-mode 1)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-globalized-minor-mode inlimg-global-mode inlimg-mode inlimg--global-turn-on)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inlimg-toggle-display (point)
|
||
|
|
"Toggle display of image at point POINT.
|
||
|
|
See also the command `inlimg-mode'."
|
||
|
|
(interactive (list (point)))
|
||
|
|
(let ((here (point))
|
||
|
|
(ovl
|
||
|
|
(catch 'ovl
|
||
|
|
(dolist (ovl (overlays-at (point)))
|
||
|
|
(when (inlimg-ovl-p ovl)
|
||
|
|
(throw 'ovl ovl)))))
|
||
|
|
is-displayed)
|
||
|
|
(if (not ovl)
|
||
|
|
(message "No image at point %s" here)
|
||
|
|
(setq is-displayed (overlay-get ovl 'after-string))
|
||
|
|
(inlimg-next (overlay-start ovl) (not is-displayed))
|
||
|
|
(goto-char here))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun inlimg-toggle-slicing (point)
|
||
|
|
"Toggle slicing of image at point POINT.
|
||
|
|
See also the command `inlimg-mode'."
|
||
|
|
(interactive (list (point)))
|
||
|
|
(let* ((here (point))
|
||
|
|
(ovl
|
||
|
|
(catch 'ovl
|
||
|
|
(dolist (ovl (overlays-at (point)))
|
||
|
|
(when (inlimg-ovl-p ovl)
|
||
|
|
(throw 'ovl ovl)))))
|
||
|
|
(inlimg-slice inlimg-slice)
|
||
|
|
is-displayed)
|
||
|
|
(if (not ovl)
|
||
|
|
(message "No image at point %s" here)
|
||
|
|
(setq is-displayed (overlay-get ovl 'after-string))
|
||
|
|
(when (overlay-get ovl 'inlimg-slice)
|
||
|
|
(setq inlimg-slice nil))
|
||
|
|
(inlimg-next (overlay-start ovl) is-displayed)
|
||
|
|
(goto-char here))))
|
||
|
|
|
||
|
|
|
||
|
|
(defun inlimg-font-lock-fun (bound)
|
||
|
|
(let ((here (point))
|
||
|
|
old-ovls new-ovls ovl)
|
||
|
|
(goto-char (line-beginning-position))
|
||
|
|
(dolist (ovl (overlays-in (point) bound))
|
||
|
|
(when (inlimg-ovl-p ovl)
|
||
|
|
(setq old-ovls (cons ovl old-ovls))))
|
||
|
|
(while (and (< (point) bound)
|
||
|
|
(setq ovl (inlimg-next (point) t)))
|
||
|
|
(setq new-ovls (cons ovl new-ovls)))
|
||
|
|
(dolist (ovl old-ovls)
|
||
|
|
(unless (inlimg-ovl-valid-p ovl)
|
||
|
|
(delete-overlay ovl)
|
||
|
|
))))
|
||
|
|
|
||
|
|
;; Fix-me: This stops working for changes with nxhtml-mumamo-mode, but
|
||
|
|
;; works for nxhtml-mode and html-mumamo-mode...
|
||
|
|
(defvar inlimg-this-is-not-font-lock-off nil)
|
||
|
|
(defun inlimg-font-lock (on)
|
||
|
|
(let ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
|
||
|
|
(link-fun))
|
||
|
|
(funcall add-or-remove nil
|
||
|
|
`((inlimg-font-lock-fun
|
||
|
|
1
|
||
|
|
mlinks-link
|
||
|
|
prepend)))
|
||
|
|
(let ((inlimg-this-is-not-font-lock-off t)
|
||
|
|
(mumamo-multi-major-mode nil))
|
||
|
|
(font-lock-mode -1)
|
||
|
|
(font-lock-mode 1))))
|
||
|
|
|
||
|
|
(defun inlimg-on-font-lock-off ()
|
||
|
|
(unless (or inlimg-this-is-not-font-lock-off
|
||
|
|
(and (boundp 'mumamo-multi-major-mode)
|
||
|
|
mumamo-multi-major-mode))
|
||
|
|
(when inlimg-mode
|
||
|
|
(inlimg-mode -1)
|
||
|
|
)))
|
||
|
|
(put 'inlimg-on-font-lock-off 'permanent-local-hook t)
|
||
|
|
|
||
|
|
|
||
|
|
(provide 'inlimg)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; inlimg.el ends here
|