1 ;;; muse-colors.el --- coloring and highlighting used by Muse
3 ;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
5 ;; Author: John Wiegley (johnw AT gnu DOT org)
6 ;; Keywords: hypermedia
7 ;; Date: Thu 11-Mar-2004
9 ;; This file is part of Emacs Muse. It is not part of GNU Emacs.
11 ;; Emacs Muse is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published
13 ;; by the Free Software Foundation; either version 2, or (at your
14 ;; option) any later version.
16 ;; Emacs Muse is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with Emacs Muse; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 ;; Lan Yufeng (nlany DOT web AT gmail DOT com) found an error where
31 ;; headings were being given the wrong face, contributing a patch to
34 ;; Sergey Vlasov (vsu AT altlinux DOT ru) fixed an issue with coloring
35 ;; links that are in consecutive lines.
37 ;; Jim Ottaway ported the <lisp> tag from emacs-wiki.
39 ;; Per B. Sederberg (per AT med DOT upenn DOT edu) contributed the
40 ;; viewing of inline images.
44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 ;; Emacs Muse Highlighting
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 (require 'muse-regexps
)
54 (defgroup muse-colors nil
55 "Options controlling the behavior of Emacs Muse highlighting.
56 See `muse-colors-buffer' for more information."
59 (defcustom muse-colors-autogen-headings t
60 "Specify whether the heading faces should be auto-generated.
61 The default is to scale them.
63 Choosing 'outline will copy the colors from the outline-mode
66 If you want to customize each of the headings individually, set
68 :type
'(choice (const :tag
"Default (scaled) headings" t
)
69 (const :tag
"Use outline-mode headings" outline
)
70 (const :tag
"Don't touch the headings" nil
))
73 (defcustom muse-colors-evaluate-lisp-tags t
74 "Specify whether to evaluate the contents of <lisp> tags at
75 display time. If nil, don't evaluate them. If non-nil, evaluate
78 The actual contents of the buffer are not changed, only the
83 (defcustom muse-colors-inline-images t
84 "Specify whether to inline images inside the Emacs buffer. If
85 nil, don't inline them. If non-nil, an image link will be
86 replaced by the image.
88 The actual contents of the buffer are not changed, only whether
89 an image is displayed."
93 (defcustom muse-colors-inline-image-method
'default-directory
94 "Determine how to locate inline images.
95 Setting this to 'default-directory uses the current directory of
96 the current Muse buffer.
98 Setting this to a function calls that function with the filename
99 of the image to be inlined. The value that is returned will be
100 used as the filename of the image."
101 :type
'(choice (const :tag
"Current directory" default-directory
)
102 (const :tag
"Publishing directory"
103 muse-colors-use-publishing-directory
)
104 (function :tag
"Custom function"))
109 (defun muse-colors-toggle-inline-images ()
110 "Toggle inlined images on/off."
112 ;; toggle the custom setting
113 (if (not muse-colors-inline-images
)
114 (setq muse-colors-inline-images t
)
115 (setq muse-colors-inline-images nil
))
116 ;; reprocess the buffer
117 (muse-colors-buffer))
119 (define-key muse-mode-map
[(control ?c
) (control ?i
)]
120 'muse-colors-toggle-inline-images
)
122 (defvar muse-colors-outline-faces-list
123 (if (facep 'outline-1
)
124 '(outline-1 outline-2 outline-3 outline-4 outline-5
)
125 ;; these are equivalent in coloring to the outline faces
126 '(font-lock-function-name-face
127 font-lock-variable-name-face
128 font-lock-keyword-face
129 font-lock-builtin-face
130 font-lock-comment-face
))
131 "Outline faces to use when assigning Muse header faces.")
133 (defun muse-make-faces-default (&optional later
)
134 (dolist (num '(1 2 3 4 5))
135 (let ((newsym (intern (concat "muse-header-" (int-to-string num
)))))
136 ;; put in the proper group and give documentation
138 (unless (featurep 'xemacs
)
139 (muse-copy-face 'variable-pitch newsym
)
140 (set-face-attribute newsym nil
:height
(1+ (* 0.1 (- 5 num
)))
142 (if (featurep 'xemacs
)
143 (eval `(defface ,newsym
145 ,(nth (1- num
) '("24pt" "18pt" "14pt" "12pt" "11pt"))
148 :group
'muse-colors
))
149 (eval `(defface ,newsym
150 '((t (:height
,(1+ (* 0.1 (- 5 num
)))
151 :inherit variable-pitch
154 :group
'muse-colors
)))))))
156 (progn (muse-make-faces-default))
158 (defun muse-make-faces (&optional frame
)
160 ((not muse-colors-autogen-headings
)
162 ((eq muse-colors-autogen-headings t
)
163 (muse-make-faces-default t
))
165 (dolist (num '(1 2 3 4 5))
166 (let ((newsym (intern (concat "muse-header-" (int-to-string num
)))))
167 ;; copy the desired face definition
168 (muse-copy-face (nth (1- num
) muse-colors-outline-faces-list
)
171 ;; after displaying the Emacs splash screen, the faces are wiped out,
172 ;; so recover from that
173 (add-hook 'window-setup-hook
#'muse-make-faces
)
174 ;; ditto for when a new frame is created
175 (when (boundp 'after-make-frame-functions
)
176 (add-hook 'after-make-frame-functions
#'muse-make-faces
))
179 '((((class color
) (background light
))
180 (:foreground
"blue" :underline
"blue" :bold t
))
181 (((class color
) (background dark
))
182 (:foreground
"cyan" :underline
"cyan" :bold t
))
184 "Face for Muse cross-references."
187 (defface muse-bad-link
188 '((((class color
) (background light
))
189 (:foreground
"red" :underline
"red" :bold t
))
190 (((class color
) (background dark
))
191 (:foreground
"coral" :underline
"coral" :bold t
))
193 "Face for bad Muse cross-references."
196 (defface muse-verbatim
197 '((((class color
) (background light
))
198 (:foreground
"slate gray"))
199 (((class color
) (background dark
))
200 (:foreground
"gray")))
201 "Face for verbatim text."
204 (defface muse-emphasis-1
206 "Face for italic emphasized text."
209 (defface muse-emphasis-2
211 "Face for bold emphasized text."
214 (defface muse-emphasis-3
215 '((t (:bold t
:italic t
)))
216 "Face for bold italic emphasized text."
219 (muse-copy-face 'italic
'muse-emphasis-1
)
220 (muse-copy-face 'bold
'muse-emphasis-2
)
221 (muse-copy-face 'bold-italic
'muse-emphasis-3
)
223 (defcustom muse-colors-buffer-hook nil
224 "A hook run after a region is highlighted.
225 Each function receives three arguments: BEG END VERBOSE.
226 BEG and END mark the range being highlighted, and VERBOSE specifies
227 whether progress messages should be displayed to the user."
231 (defvar muse-colors-regexp nil
)
232 (defvar muse-colors-vector nil
)
234 (defun muse-configure-highlighting (sym val
)
237 (let ((val (cond ((symbolp (car rule
))
238 (symbol-value (car rule
)))
239 ((stringp (car rule
))
242 (when val
(setq regexps
(cons val regexps
)))))
243 (setq muse-colors-regexp
(concat "\\("
244 (mapconcat #'identity regexps
"\\|")
246 muse-colors-vector
(make-vector 128 nil
)))
249 (if (eq (cadr (car rules
)) t
)
252 (unless (aref muse-colors-vector i
)
253 (aset muse-colors-vector i
(nth 2 (car rules
))))
255 (aset muse-colors-vector
(cadr (car rules
))
256 (nth 2 (car rules
))))
257 (setq rules
(cdr rules
))))
263 (defun muse-colors-emphasized ()
264 ;; Here we need to check four different points - the start and end
265 ;; of the leading *s, and the start and end of the trailing *s. We
266 ;; allow the outsides to be surrounded by whitespace or punctuation,
267 ;; but no word characters, and the insides must not be surrounded by
268 ;; whitespace or punctuation. Thus the following are valid:
272 ;; and the following is invalid:
274 (let* ((beg (match-beginning 0))
278 (unless (eq (get-text-property beg
'invisible
) 'muse
)
279 ;; check if it's a header
280 (if (eq (char-after e1
) ?\
)
281 (when (or (= beg
(point-min))
282 (eq (char-before beg
) ?
\n))
284 (muse-line-beginning-position) (muse-line-end-position)
285 (list 'face
(intern (concat "muse-header-"
286 (int-to-string leader
))))))
287 ;; beginning of line or space or symbol
288 (when (or (= beg
(point-min))
289 (eq (char-syntax (char-before beg
)) ?\
)
290 (memq (char-before beg
)
291 '(?\- ?\
[ ?\
< ?\
( ?
\' ?\
` ?
\" ?
\n)))
293 (skip-chars-forward "^*<>\n" end
)
294 (when (eq (char-after) ?
\n)
296 (skip-chars-forward "^*<>" end
))
298 (skip-chars-forward "*" end
)
300 ;; Abort if space exists just before end
303 ;; or word constituent follows
304 (unless (or (> leader
5)
305 (not (eq leader
(- e2 b2
)))
306 (eq (char-syntax (char-before b2
)) ?\
)
307 (not (eq (char-after b2
) ?
*))
309 (eq (char-syntax (char-after (1+ b2
))) ?w
)))
310 (add-text-properties beg e1
'(invisible muse
))
312 e1 b2
(list 'face
(cond ((= leader
1) 'muse-emphasis-1
)
313 ((= leader
2) 'muse-emphasis-2
)
314 ((= leader
3) 'muse-emphasis-3
))))
315 (add-text-properties b2 e2
'(invisible muse
))
318 beg e2
'(font-lock-multiline t
))))))))))
320 (defun muse-colors-underlined ()
321 (let ((start (match-beginning 0))
323 (unless (eq (get-text-property start
'invisible
) 'muse
)
324 ;; beginning of line or space or symbol
325 (when (or (= start
(point-min))
326 (eq (char-syntax (char-before start
)) ?\
)
327 (memq (char-before start
)
328 '(?\- ?\
[ ?\
< ?\
( ?
\' ?\
` ?
\" ?
\n)))
330 (skip-chars-forward "^_<>\n" end
)
331 (when (eq (char-after) ?
\n)
333 (skip-chars-forward "^_<>" end
))
334 ;; Abort if space exists just before end
336 ;; or word constituent follows
337 (unless (or (eq (char-syntax (char-before (point))) ?\
)
338 (not (eq (char-after (point)) ?_
))
340 (eq (char-syntax (char-after (1+ (point)))) ?w
)))
341 (add-text-properties start
(1+ start
) '(invisible muse
))
342 (add-text-properties (1+ start
) (point) '(face underline
))
343 (add-text-properties (point)
344 (min (1+ (point)) (point-max))
348 start
(min (1+ (point)) (point-max))
349 '(font-lock-multiline t
)))))))))
351 (defun muse-colors-verbatim ()
352 (let ((start (match-beginning 0))
354 (unless (eq (get-text-property start
'invisible
) 'muse
)
355 ;; beginning of line or space or symbol
356 (when (or (= start
(point-min))
357 (eq (char-syntax (char-before start
)) ?\
)
358 (memq (char-before start
)
359 '(?\- ?\
[ ?\
< ?\
( ?
\' ?\
` ?
\" ?
\n)))
361 (skip-chars-forward "^=\n" end
)
362 (when (eq (char-after) ?
\n)
364 (skip-chars-forward "^=" end
))
365 ;; Abort if space exists just before end
367 ;; or word constituent follows
368 (unless (or (eq (char-syntax (char-before (point))) ?\
)
369 (not (eq (char-after (point)) ?
=))
371 (eq (char-syntax (char-after (1+ (point)))) ?w
)))
372 (setq pos
(min (1+ (point)) (point-max)))
373 (add-text-properties start
(1+ start
) '(invisible muse
))
374 (add-text-properties (1+ start
) (point) '(face muse-verbatim
))
375 (add-text-properties (point)
376 (min (1+ (point)) (point-max))
380 start
(min (1+ (point)) (point-max))
381 '(font-lock-multiline t
))))
384 (defcustom muse-colors-markup
385 `(;; make emphasized text appear emphasized
386 ("\\*\\{1,5\\}" ?
* muse-colors-emphasized
)
388 ;; make underlined text appear underlined
389 (,(concat "_[^" muse-regexp-blank
"_\n]")
390 ?_ muse-colors-underlined
)
392 ("^#title " ?\
# muse-colors-title
)
394 (muse-explicit-link-regexp ?\
[ muse-colors-explicit-link
)
396 ;; render in teletype and suppress further parsing
397 (,(concat "=[^" muse-regexp-blank
"=\n]") ?
= muse-colors-verbatim
)
399 ;; highlight any markup tags encountered
400 (muse-tag-regexp ?\
< muse-colors-custom-tags
)
402 ;; this has to come later since it doesn't have a special
403 ;; character in the second cell
404 (muse-url-regexp t muse-colors-implicit-link
)
406 "Expressions to highlight an Emacs Muse buffer.
407 These are arranged in a rather special fashion, so as to be as quick as
410 Each element of the list is itself a list, of the form:
412 (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
414 LOCATE-REGEXP is a partial regexp, and should be the smallest possible
415 regexp to differentiate this rule from other rules. It may also be a
416 symbol containing such a regexp. The buffer region is scanned only
417 once, and LOCATE-REGEXP indicates where the scanner should stop to
418 look for highlighting possibilities.
420 TEST-CHAR is a char or t. The character should match the beginning
421 text matched by LOCATE-REGEXP. These chars are used to build a vector
422 for fast MATCH-FUNCTION calling.
424 MATCH-FUNCTION is the function called when a region has been
425 identified. It is responsible for adding the appropriate text
426 properties to change the appearance of the buffer.
428 This markup is used to modify the appearance of the original text to
429 make it look more like the published HTML would look (like making some
430 markup text invisible, inlining images, etc).
432 font-lock is used to apply the markup rules, so that they can happen
433 on a deferred basis. They are not always accurate, but you can use
434 \\[font-lock-fontifty-block] near the point of error to force
435 fontification in that area.
437 Lastly, none of the regexp should contain grouping elements that will
438 affect the match data results."
440 (list :tag
"Highlight rule"
441 (choice (regexp :tag
"Locate regexp")
442 (symbol :tag
"Regexp symbol"))
443 (choice (character :tag
"Confirm character")
444 (const :tag
"Default rule" t
))
446 :set
'muse-configure-highlighting
449 ;; XEmacs users don't have `font-lock-multiline'.
450 (unless (boundp 'font-lock-multiline
)
451 (defvar font-lock-multiline nil
))
453 (defun muse-use-font-lock ()
454 (muse-add-to-invisibility-spec 'muse
)
455 (set (make-local-variable 'font-lock-multiline
) 'undecided
)
456 (set (make-local-variable 'font-lock-defaults
)
457 `(nil t nil nil
'beginning-of-line
458 (font-lock-fontify-region-function . muse-colors-region
)
459 (font-lock-unfontify-region-function
460 . muse-unhighlight-region
)))
461 (set (make-local-variable 'font-lock-fontify-region-function
)
463 (set (make-local-variable 'font-lock-unfontify-region-function
)
464 'muse-unhighlight-region
)
466 (muse-configure-highlighting 'muse-colors-markup muse-colors-markup
)
469 (defun muse-colors-buffer ()
470 "Re-highlight the entire Muse buffer."
472 (muse-colors-region (point-min) (point-max) t
))
474 (defvar muse-colors-fontifying-p nil
475 "Indicate whether Muse is fontifying the current buffer.")
476 (make-variable-buffer-local 'muse-colors-fontifying-p
)
478 (defun muse-colors-region (beg end
&optional verbose
)
479 "Apply highlighting according to `muse-colors-markup'.
480 Note that this function should NOT change the buffer, nor should any
481 of the functions listed in `muse-colors-markup'."
482 (let ((buffer-undo-list t
)
483 (inhibit-read-only t
)
484 (inhibit-point-motion-hooks t
)
485 (inhibit-modification-hooks t
)
486 (modified-p (buffer-modified-p))
487 (muse-colors-fontifying-p t
)
493 ;; check to see if we should expand the beg/end area for
494 ;; proper multiline matches
495 (when (and font-lock-multiline
497 (get-text-property (1- beg
) 'font-lock-multiline
))
498 ;; We are just after or in a multiline match.
499 (setq beg
(or (previous-single-property-change
500 beg
'font-lock-multiline
)
503 (setq beg
(muse-line-beginning-position)))
504 (when font-lock-multiline
505 (setq end
(or (text-property-any end
(point-max)
506 'font-lock-multiline nil
)
509 (setq end
(muse-line-beginning-position 2))
510 ;; Undo any fontification in the area.
511 (font-lock-unfontify-region beg end
)
512 ;; And apply fontification based on `muse-colors-markup'
513 (let ((len (float (- end beg
)))
514 (case-fold-search nil
)
517 (while (and (< (point) end
)
518 (re-search-forward muse-colors-regexp end t
))
520 (message "Highlighting buffer...%d%%"
521 (* (/ (float (- (point) beg
)) len
) 100)))
523 (aref muse-colors-vector
524 (char-after (match-beginning 0))))
525 (when markup-func
(funcall markup-func
)))
526 (run-hook-with-args 'muse-colors-buffer-hook
528 (if verbose
(message "Highlighting buffer...done")))))
529 (set-buffer-modified-p modified-p
))))
531 (defcustom muse-colors-tags
532 '(("example" t nil muse-colors-example-tag
)
533 ("code" t nil muse-colors-example-tag
)
534 ("verbatim" t nil muse-colors-literal-tag
)
535 ("lisp" t t muse-colors-lisp-tag
)
536 ("literal" t nil muse-colors-literal-tag
))
537 "A list of tag specifications for specially highlighting text.
538 XML-style tags are the best way to add custom highlighting to Muse.
539 This is easily accomplished by customizing this list of markup tags.
541 For each entry, the name of the tag is given, whether it expects
542 a closing tag and/or an optional set of attributes, and a
543 function that performs whatever action is desired within the
546 The function is called with three arguments, the beginning and
547 end of the region surrounded by the tags. If properties are
548 allowed, they are passed as a third argument in the form of an
549 alist. The `end' argument to the function is the last character
550 of the enclosed tag or region.
552 Functions should not modify the contents of the buffer."
553 :type
'(repeat (list (string :tag
"Markup tag")
554 (boolean :tag
"Expect closing tag" :value t
)
555 (boolean :tag
"Parse attributes" :value nil
)
559 (defsubst muse-colors-tag-info
(tagname &rest args
)
560 (assoc tagname muse-colors-tags
))
562 (defun muse-colors-custom-tags ()
563 "Highlight `muse-colors-tags'."
564 (let ((tag-info (muse-colors-tag-info (match-string 4))))
566 (let ((closed-tag (match-string 3))
567 (start (match-beginning 0))
569 (when (nth 2 tag-info
)
570 (let ((attrstr (match-string 2)))
572 (string-match (concat "\\([^"
575 "\\([^\"]+\\)\"\\)?")
577 (let ((attr (cons (downcase
578 (muse-match-string-no-properties 1 attrstr
))
579 (muse-match-string-no-properties 3 attrstr
))))
580 (setq attrstr
(replace-match "" t t attrstr
))
582 (nconc attrs
(list attr
))
583 (setq attrs
(list attr
)))))))
584 (if (and (cadr tag-info
) (not closed-tag
))
585 (if (search-forward (concat "</" (car tag-info
) ">") nil t
)
586 (setq end
(match-end 0))
587 (setq tag-info nil
)))
589 (let ((args (list start end
)))
591 (nconc args
(list attrs
)))
592 (apply (nth 3 tag-info
) args
)))))))
594 (defun muse-unhighlight-region (begin end
&optional verbose
)
595 "Remove all visual highlights in the buffer (except font-lock)."
596 (let ((buffer-undo-list t
)
597 (inhibit-read-only t
)
598 (inhibit-point-motion-hooks t
)
599 (inhibit-modification-hooks t
)
600 (modified-p (buffer-modified-p))
603 (remove-text-properties
604 begin end
'(face nil font-lock-multiline nil end-glyph nil
605 invisible nil intangible nil display nil
606 mouse-face nil keymap nil help-echo nil
608 (set-buffer-modified-p modified-p
))))
610 (defun muse-colors-example-tag (beg end
)
611 "Strip properties and colorize with `muse-verbatim'."
612 (muse-unhighlight-region beg end
)
613 (let ((multi (save-excursion
617 (add-text-properties beg end
`(face muse-verbatim
618 font-lock-multiline
,multi
))))
620 (defun muse-colors-literal-tag (beg end
)
621 "Strip properties and mark as literal."
622 (muse-unhighlight-region beg end
)
623 (let ((multi (save-excursion
627 (add-text-properties beg end
`(font-lock-multiline ,multi
))))
629 (defun muse-colors-lisp-tag (beg end attrs
)
630 (if (not muse-colors-evaluate-lisp-tags
)
631 (muse-colors-literal-tag beg end
)
632 (muse-unhighlight-region beg end
)
633 (let (beg-lisp end-lisp
)
636 (setq beg-lisp
(and (looking-at "<[^>]+>")
639 (setq end-lisp
(and (muse-looking-back "</[^>]+>")
640 (match-beginning 0))))
643 (list 'font-lock-multiline t
644 'display
(muse-eval-lisp
647 (buffer-substring-no-properties beg-lisp end-lisp
)
651 (defvar muse-mode-local-map
652 (let ((map (make-sparse-keymap)))
653 (define-key map
[return] 'muse-follow-name-at-point)
654 (define-key map [(control ?m)] 'muse-follow-name-at-point)
655 (define-key map [(shift return)] 'muse-follow-name-at-point-other-window)
656 (if (featurep 'xemacs)
658 (define-key map [(button2)] 'muse-follow-name-at-mouse)
659 (define-key map [(shift button2)]
660 'muse-follow-name-at-mouse-other-window))
661 (define-key map [(shift control ?m)]
662 'muse-follow-name-at-point-other-window)
663 (define-key map [mouse-2] 'muse-follow-name-at-mouse)
664 (define-key map [(shift mouse-2)]
665 'muse-follow-name-at-mouse-other-window)
666 (unless (eq emacs-major-version 21)
667 (set-keymap-parent map muse-mode-map)))
669 "Local keymap used by Muse while on a link.")
671 (defvar muse-keymap-property
672 (if (or (featurep 'xemacs)
673 (>= emacs-major-version 21))
677 (defsubst muse-link-properties (help-str &optional face)
679 (list 'face face 'mouse-face 'highlight 'muse-link t)
680 (list 'invisible 'muse 'intangible t))
681 (list 'help-echo help-str 'rear-nonsticky t
682 muse-keymap-property muse-mode-local-map)))
684 (defun muse-link-face (link-name &optional explicit)
685 "Return the type of LINK-NAME as a face symbol.
686 For EXPLICIT links, this is either a normal link or a bad-link
687 face. For implicit links, it is either colored normally or
690 (let ((link (if explicit
691 (muse-handle-explicit-link link-name)
692 (muse-handle-implicit-link link-name))))
694 (cond ((string-match muse-url-regexp link)
696 ((string-match muse-file-regexp link)
697 (if (file-exists-p link)
700 ((not (featurep 'muse-project))
703 (if (string-match "#" link)
704 (setq link (substring link 0 (match-beginning 0))))
705 (if (or (and (muse-project-of-file)
706 (muse-project-page-file
707 link muse-current-project t))
708 (file-exists-p link))
710 'muse-bad-link)))))))
712 (defun muse-colors-use-publishing-directory (link)
713 "Make LINK relative to the directory where we will publish the
715 (let ((style (car (muse-project-applicable-styles
716 link (cddr (muse-project)))))
719 (setq path (muse-style-element :path style)))
720 (expand-file-name link path))))
722 (defun muse-colors-resolve-image-file (link)
723 "Determine if we can create images and see if the link is an image
726 (and (or (fboundp 'create-image)
727 (fboundp 'make-glyph))
728 (string-match muse-image-regexp link))))
730 (defun muse-make-file-glyph (filename)
731 "Given a file name, return a newly-created image glyph.
732 This is a hack for supporting inline images in XEmacs."
733 (let ((case-fold-search nil))
734 ;; Scan filename to determine image type
735 (when (fboundp 'make-glyph)
737 (cond ((string-match "jpe?g" filename)
738 (make-glyph (vector 'jpeg :file filename) 'buffer))
739 ((string-match "gif" filename)
740 (make-glyph (vector 'gif :file filename) 'buffer))
741 ((string-match "png" filename)
742 (make-glyph (vector 'png :file filename) 'buffer)))))))
744 (defun muse-colors-insert-image (link beg end invis-props)
745 "Create an image using create-image or make-glyph and insert it
746 in place of an image link defined by BEG and END."
747 (setq link (expand-file-name link))
748 (let ((image-file (cond
749 ((eq muse-colors-inline-image-method 'default-directory)
751 ((functionp muse-colors-inline-image-method)
752 (funcall muse-colors-inline-image-method link))))
754 (when (stringp image-file)
755 (if (fboundp 'create-image)
756 ;; use create-image and display property
757 (add-text-properties beg end
758 (list 'display (create-image image-file)))
759 ;; use make-glyph and invisible property
760 (and (setq glyph (muse-make-file-glyph image-file))
762 (add-text-properties beg end invis-props)
763 (add-text-properties beg end (list
765 'help-echo link))))))))
767 (defun muse-colors-explicit-link ()
768 "Color explicit links."
769 (when (eq ?\[ (char-after (match-beginning 0)))
770 ;; remove flyspell overlays
771 (when (fboundp 'flyspell-unhighlight-at)
772 (let ((cur (match-beginning 0)))
773 (while (> (match-end 0) cur)
774 (flyspell-unhighlight-at cur)
775 (setq cur (1+ cur)))))
777 (goto-char (match-beginning 0))
778 (looking-at muse-explicit-link-regexp))
779 (let* ((unesc-link (muse-get-link))
780 (unesc-desc (muse-get-link-desc))
781 (link (muse-link-unescape unesc-link))
782 (desc (muse-link-unescape unesc-desc))
783 (props (muse-link-properties desc (muse-link-face link t)))
784 (invis-props (append props (muse-link-properties desc))))
785 ;; see if we should try and inline an image
786 (if (and muse-colors-inline-images
787 (or (muse-colors-resolve-image-file link)
789 (muse-colors-resolve-image-file desc)
791 ;; we found an image, so inline it
792 (muse-colors-insert-image
794 (match-beginning 0) (match-end 0) invis-props)
797 ;; we put the normal face properties on the invisible
798 ;; portion too, since emacs sometimes will position
799 ;; the cursor on an intangible character
800 (add-text-properties (match-beginning 0)
801 (match-beginning 2) invis-props)
802 (add-text-properties (match-beginning 2) (match-end 2) props)
803 (add-text-properties (match-end 2) (match-end 0) invis-props)
804 ;; in case specials were escaped, cause the unescaped
805 ;; text to be displayed
806 (unless (string= desc unesc-desc)
807 (add-text-properties (match-beginning 2) (match-end 2)
808 (list 'display desc))))
809 (add-text-properties (match-beginning 0)
810 (match-beginning 1) invis-props)
811 (add-text-properties (match-beginning 1) (match-end 0) props)
812 (add-text-properties (match-end 1) (match-end 0) invis-props)
813 (unless (string= link unesc-link)
814 (add-text-properties (match-beginning 1) (match-end 1)
815 (list 'display link))))
816 (goto-char (match-end 0))
818 (match-beginning 0) (match-end 0)
819 (muse-link-properties (muse-match-string-no-properties 0)
820 (muse-link-face link t)))))))
822 (defun muse-colors-implicit-link ()
823 "Color implicit links."
824 ;; remove flyspell overlays
825 (when (fboundp 'flyspell-unhighlight-at)
826 (let ((cur (match-beginning 0)))
827 (while (> (match-end 0) cur)
828 (flyspell-unhighlight-at cur)
829 (setq cur (1+ cur)))))
830 (unless (or (eq (get-text-property (match-beginning 0) 'invisible) 'muse)
831 (eq (char-before (match-beginning 0)) ?\")
832 (eq (char-after (match-end 0)) ?\"))
833 (let ((link (muse-match-string-no-properties 1))
834 (face (muse-link-face (match-string 1))))
836 (add-text-properties (match-beginning 1) (match-end 0)
837 (muse-link-properties
838 (muse-match-string-no-properties 1) face))))))
840 (defun muse-colors-title ()
841 (add-text-properties (+ 7 (match-beginning 0))
842 (muse-line-end-position)
843 '(face muse-header-1)))
845 (provide 'muse-colors)
847 ;;; muse-colors.el ends here