nxhtml/util/inlimg.el

   1 ;;; inlimg.el --- Display images inline
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-09-27
   5 (defconst inlimg:version "0.7") ;; Version:
   6 ;; Last-Updated: 2009-07-14 Tue
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; Display images inline.  See `inlimg-mode' for more information.
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or
  29 ;; modify it under the terms of the GNU General Public License as
  30 ;; published by the Free Software Foundation; either version 2, or
  31 ;; (at your option) any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  36 ;; General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to
  40 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  41 ;; Floor, Boston, MA 02110-1301, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  47 (eval-when-compile (require 'cl))
  48 (eval-when-compile (require 'mumamo nil t))
  49 (eval-when-compile (require 'ourcomments-util nil t))
  50
  51 (defvar inlimg-assoc-ext
  52   '((png  (".png"))
  53     (gif  (".gif"))
  54     (tiff (".tiff"))
  55     (jpeg (".jpg" ".jpeg"))
  56     (xpm  (".xpm"))
  57     (xbm  (".xbm"))
  58     (pbm  (".pbm"))))
  59
  60 (defvar inlimg-img-regexp nil)
  61 (make-variable-buffer-local 'inlimg-img-regexp)
  62 (put 'inlimg-img-regexp 'permanent-local t)
  63
  64 (defvar inlimg-img-regexp-html
  65   (rx (or (and "<img"
  66                (1+ space)
  67                (0+ (1+ (not (any " <>")))
  68                    (1+ space))
  69                "src=\""
  70                (group (1+ (not (any "\""))))
  71                "\""
  72                (*? anything)
  73                "/>")
  74           (and "url("
  75                ?\"
  76                (group (1+ (not (any "\)"))))
  77                ?\"
  78                ")"
  79                )
  80           (and "url("
  81                (group (+? (not (any ")"))))
  82                ")"
  83                )
  84           )))
  85
  86 (defvar inlimg-img-regexp-org
  87   (rx-to-string
  88    `(and "[[file:"
  89          (group (+? (not (any "\]")))
  90                 ,(let ((types nil))
  91                    (dolist (typ image-types)
  92                      (when (image-type-available-p typ)
  93                        (dolist (ext (cadr (assoc typ inlimg-assoc-ext)))
  94                          (setq types (cons ext types)))))
  95                    (cons 'or types)))
  96          "]"
  97          (optional "["
  98                    (+? (not (any "\]")))
  99                    "]")
 100          "]"
 101          )))
 102
 103 (defconst inlimg-modes-img-values
 104   '(
 105     (html-mode inlimg-img-regexp-html)
 106     (org-mode  inlimg-img-regexp-org)
 107     ))
 108
 109 (defun inlimg-img-spec-p (spec)
 110   (assoc spec inlimg-modes-img-values))
 111
 112 ;;;###autoload
 113 (defgroup inlimg nil
 114   "Customization group for inlimg."
 115   :group 'nxhtml)
 116
 117 (defcustom inlimg-margins '(50 . 5)
 118   "Margins when displaying image."
 119   :type '(cons (integer :tag "Left margin")
 120                (integer :tag "Top margin"))
 121   :set (lambda (sym val)
 122          (set-default sym val)
 123          (when (fboundp 'inlimg-update-all-buffers)
 124            (inlimg-update-all-buffers)))
 125   :group 'inlimg)
 126
 127 (defcustom inlimg-slice '(0 0 400 100)
 128   "How to slice images."
 129   :type '(choice (const :tag "Show whole images" nil)
 130                  (list :tag "Show slice of image"
 131                        (integer :tag "Top")
 132                        (integer :tag "Left")
 133                        (integer :tag "Width")
 134                        (integer :tag "Height")))
 135   :set (lambda (sym val)
 136          (set-default sym val)
 137          (when (fboundp 'inlimg-update-all-buffers)
 138            (inlimg-update-all-buffers)))
 139   :group 'inlimg)
 140
 141 (define-widget 'inlimg-spec-widget 'symbol
 142   "An inline image specification."
 143   :complete-function (lambda ()
 144                        (interactive)
 145                        (lisp-complete-symbol 'inlimg-img-spec-p))
 146   :prompt-match 'inlimg-img-spec-p
 147   :prompt-history 'widget-function-prompt-value-history
 148   :match-alternatives '(inlimg-img-spec-p)
 149   :validate (lambda (widget)
 150               (unless (inlimg-img-spec-p (widget-value widget))
 151                 (widget-put widget :error (format "Invalid function: %S"
 152                                                   (widget-value widget)))
 153                 widget))
 154   :value 'org-mode
 155   :tag "Inlimg image values spec name")
 156
 157 ;; (customize-option 'inlimg-mode-specs)
 158 (defcustom inlimg-mode-specs
 159   '(
 160     (xml-mode html-mode)
 161     (sgml-mode html-mode)
 162     (nxml-mode html-mode)
 163     (php-mode html-mode)
 164     (css-mode html-mode)
 165     )
 166   "Equivalent mode for image tag search.
 167 Note that derived modes \(see info) are recognized by default.
 168
 169 To add new image tag patterns modify `inlimg-modes-img-values'."
 170   :type '(repeat
 171           (list (major-mode-function :tag "Major mode")
 172                 (inlimg-spec-widget :tag "Use tags as specified in")))
 173   :group 'inlimg)
 174
 175 (defface inlimg-img-tag '((t :inherit 'lazy-highlight))
 176   "Face added to img tag when displaying image."
 177   :group 'inlimg)
 178
 179 (defface inlimg-img-remote '((t :inherit 'isearch-fail))
 180   "Face used for notes telling image is remote."
 181   :group 'inlimg)
 182
 183 (defface inlimg-img-missing '((t :inherit 'trailing-whitespace))
 184   "Face used for notes telling image is missing."
 185   :group 'inlimg)
 186
 187 (defvar inlimg-img-keymap
 188   (let ((map (make-sparse-keymap)))
 189     (define-key map [(control ?c) ?+] 'inlimg-toggle-display)
 190     (define-key map [(control ?c) ?%] 'inlimg-toggle-slicing)
 191     map)
 192   "Keymap on image overlay.")
 193
 194 (eval-after-load 'gimp
 195   '(gimp-add-point-bindings inlimg-img-keymap))
 196
 197 (defsubst inlimg-ovl-p (ovl)
 198   "Return non-nil if OVL is an inlimg image overlay."
 199   (overlay-get ovl 'inlimg-img))
 200
 201 (defun inlimg-ovl-valid-p (ovl)
 202   (and (overlay-get ovl 'inlimg-img)
 203        inlimg-img-regexp
 204        (save-match-data
 205          (let ((here (point)))
 206            (goto-char (overlay-start ovl))
 207            (prog1
 208                (looking-at (symbol-value inlimg-img-regexp))
 209              (goto-char here))))))
 210
 211 (defun inlimg-next (pt display-image)
 212   "Display or hide next image after point PT.
 213 If DISPLAY-IMAGE is non-nil then display image, otherwise hide it.
 214
 215 Return non-nil if an img tag was found."
 216   (when inlimg-img-regexp
 217     (let (src dir beg end img ovl remote beg-face)
 218       (goto-char pt)
 219       (save-match-data
 220         (when (re-search-forward (symbol-value inlimg-img-regexp) nil t)
 221           (setq src (or (match-string-no-properties 1)
 222                         (match-string-no-properties 2)
 223                         (match-string-no-properties 3)))
 224           (setq beg (match-beginning 0))
 225           (setq beg-face (get-text-property beg 'face))
 226           (setq remote (string-match "^https?://" src))
 227           (setq end (- (line-end-position) 0))
 228           (setq ovl (catch 'old-ovl
 229                       (dolist (ovl (overlays-at beg))
 230                         (when (inlimg-ovl-p ovl)
 231                           (throw 'old-ovl ovl)))
 232                       nil))
 233           (unless ovl
 234             (setq ovl (make-overlay beg end))
 235             (overlay-put ovl 'inlimg-img t)
 236             (overlay-put ovl 'priority 100)
 237             (overlay-put ovl 'face 'inlimg-img-tag)
 238             (overlay-put ovl 'keymap inlimg-img-keymap))
 239           (overlay-put ovl 'image-file src)
 240           (overlay-put ovl 'inlimg-slice inlimg-slice)
 241           (if display-image
 242               (unless (memq beg-face '(font-lock-comment-face font-lock-string-face))
 243                 (unless remote
 244                   (setq dir (if (buffer-file-name)
 245                                 (file-name-directory (buffer-file-name))
 246                               default-directory))
 247                   (setq src (expand-file-name src dir)))
 248                 (if (or remote (not (file-exists-p src)))
 249                     (setq img (propertize
 250                                (if remote " Image is on the web " " Image not found ")
 251                                'face (if remote 'inlimg-img-remote 'inlimg-img-missing)))
 252                   (setq img (create-image src nil nil
 253                                           :relief 5
 254                                           :margin inlimg-margins))
 255                   (setq img (inlimg-slice-img img inlimg-slice)))
 256                 (let ((str (copy-sequence "\nX")))
 257                   (setq str (propertize str 'face 'inlimg-img-tag))
 258                   (put-text-property 1 2 'display img str)
 259                   (overlay-put ovl 'after-string str)))
 260             (overlay-put ovl 'after-string nil))))
 261       ovl)))
 262
 263 (defun inlimg-slice-img (img slice)
 264   (if (not slice)
 265       img
 266     (let* ((sizes (image-size img t))
 267            (width  (car sizes))
 268            (height (cdr sizes))
 269            (sl-left (nth 0 slice))
 270            (sl-top (nth 1 slice))
 271            (sl-width (nth 2 slice))
 272            (sl-height (nth 3 slice)))
 273       (when (> sl-left width) (setq sl-left 0))
 274       (when (> (+ sl-left sl-width) width) (setq sl-width (- width sl-left)))
 275       (when (> sl-top height) (setq sl-top 0))
 276       (when (> (+ sl-top sl-height) height) (setq sl-height (- height sl-top)))
 277       (setq img (list img))
 278       (setq img (cons (append '(slice)
 279                               slice
 280                               (list sl-top sl-left sl-width sl-height)
 281                               nil)
 282                       img)))))
 283
 284 ;;;###autoload
 285 (define-minor-mode inlimg-mode
 286   "Display images inline.
 287 Search buffer for image tags.  Display found images.
 288
 289 Image tags are setup per major mode in `inlimg-mode-specs'.
 290
 291 Images are displayed on a line below the tag referencing them.
 292 The whole image or a slice of it may be displayed, see
 293 `inlimg-slice'.  Margins relative text are specified in
 294 `inlimg-margins'.
 295
 296 See also the commands `inlimg-toggle-display' and
 297 `inlimg-toggle-slicing'.
 298
 299 Note: This minor mode uses `font-lock-mode'."
 300   :keymap nil
 301   :group 'inlimg
 302   (if inlimg-mode
 303       (progn
 304         (let ((major-mode (or (and (boundp 'mumamo-multi-major-mode)
 305                                    mumamo-multi-major-mode
 306                                    (fboundp 'mumamo-main-major-mode)
 307                                    (mumamo-main-major-mode))
 308                               major-mode)))
 309           (inlimg-get-buffer-img-values)
 310           (unless inlimg-img-regexp
 311             (message "inlim-mode: No image spec, can't do anything"))
 312           (add-hook 'font-lock-mode-hook 'inlimg-on-font-lock-off))
 313         (inlimg-font-lock t))
 314     (inlimg-font-lock nil)
 315     (inlimg-delete-overlays)))
 316 (put 'inlimg-mode 'permanent-local t)
 317
 318 (defun inlimg-delete-overlays ()
 319   (save-restriction
 320     (widen)
 321     (let (ovl)
 322       (dolist (ovl (overlays-in (point-min) (point-max)))
 323         (when (inlimg-ovl-p ovl)
 324           (delete-overlay ovl))))))
 325
 326 (defun inlimg-get-buffer-img-values ()
 327   (let* (rec
 328          (spec (or (catch 'spec
 329                      (dolist (rec inlimg-mode-specs)
 330                        (when (derived-mode-p (car rec))
 331                          (throw 'spec (nth 1 rec)))))
 332                    major-mode))
 333         (values (when spec (nth 1 (assoc spec inlimg-modes-img-values))))
 334         )
 335     (setq inlimg-img-regexp values)
 336     ))
 337
 338 (defun inlimg--global-turn-on ()
 339   (inlimg-get-buffer-img-values)
 340   (when inlimg-img-regexp
 341     (inlimg-mode 1)))
 342
 343 ;;;###autoload
 344 (define-globalized-minor-mode inlimg-global-mode inlimg-mode inlimg--global-turn-on)
 345
 346 ;;;###autoload
 347 (defun inlimg-toggle-display (point)
 348   "Toggle display of image at point POINT.
 349 See also the command `inlimg-mode'."
 350   (interactive (list (point)))
 351   (let ((here (point))
 352         (ovl
 353          (catch 'ovl
 354            (dolist (ovl (overlays-at (point)))
 355              (when (inlimg-ovl-p ovl)
 356                (throw 'ovl ovl)))))
 357         is-displayed)
 358     (if (not ovl)
 359         (message "No image at point %s" here)
 360       (setq is-displayed (overlay-get ovl 'after-string))
 361       (inlimg-next (overlay-start ovl) (not is-displayed))
 362       (goto-char here))))
 363
 364 ;;;###autoload
 365 (defun inlimg-toggle-slicing (point)
 366   "Toggle slicing of image at point POINT.
 367 See also the command `inlimg-mode'."
 368   (interactive (list (point)))
 369   (let* ((here (point))
 370          (ovl
 371          (catch 'ovl
 372            (dolist (ovl (overlays-at (point)))
 373              (when (inlimg-ovl-p ovl)
 374                (throw 'ovl ovl)))))
 375          (inlimg-slice inlimg-slice)
 376         is-displayed)
 377     (if (not ovl)
 378         (message "No image at point %s" here)
 379       (setq is-displayed (overlay-get ovl 'after-string))
 380       (when (overlay-get ovl 'inlimg-slice)
 381         (setq inlimg-slice nil))
 382       (inlimg-next (overlay-start ovl) is-displayed)
 383       (goto-char here))))
 384
 385
 386 (defun inlimg-font-lock-fun (bound)
 387   (let ((here (point))
 388         old-ovls new-ovls ovl)
 389     (goto-char (line-beginning-position))
 390     (dolist (ovl (overlays-in (point) bound))
 391       (when (inlimg-ovl-p ovl)
 392         (setq old-ovls (cons ovl old-ovls))))
 393     (while (and (< (point) bound)
 394                 (setq ovl (inlimg-next (point) t)))
 395       (setq new-ovls (cons ovl new-ovls)))
 396     (dolist (ovl old-ovls)
 397       (unless (inlimg-ovl-valid-p ovl)
 398         (delete-overlay ovl)
 399         ))))
 400
 401 ;; Fix-me: This stops working for changes with nxhtml-mumamo-mode, but
 402 ;; works for nxhtml-mode and html-mumamo-mode...
 403 (defvar inlimg-this-is-not-font-lock-off nil)
 404 (defun inlimg-font-lock (on)
 405   (let ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
 406         (link-fun))
 407     (funcall add-or-remove nil
 408              `((inlimg-font-lock-fun
 409                 1
 410                 mlinks-link
 411                 prepend)))
 412     (let ((inlimg-this-is-not-font-lock-off t)
 413           (mumamo-multi-major-mode nil))
 414       (font-lock-mode -1)
 415       (font-lock-mode 1))))
 416
 417 (defun inlimg-on-font-lock-off ()
 418   (unless (or inlimg-this-is-not-font-lock-off
 419               (and (boundp 'mumamo-multi-major-mode)
 420                    mumamo-multi-major-mode))
 421     (when inlimg-mode
 422       (inlimg-mode -1)
 423       )))
 424 (put 'inlimg-on-font-lock-off 'permanent-local-hook t)
 425
 426
 427 (provide 'inlimg)
 428 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 429 ;;; inlimg.el ends here