From: Drew Adams <drew.adams@oracle.com>
To: 18367@debbugs.gnu.org
Subject: bug#18367: 24.4.50; [PATCH] Text property `font-lock-ignore', to protect from font-lock
Date: Sat, 30 Aug 2014 13:12:44 -0700 (PDT) [thread overview]
Message-ID: <86f1a219-9ab5-439f-85ca-936b942cb034@default> (raw)
[-- Attachment #1: Type: text/plain, Size: 1152 bytes --]
Bug or missing feature: Prevent font-lock from changing text
properties on text that has property `font-lock-ignore'. See
http://lists.gnu.org/archive/html/emacs-devel/2014-08/msg00540.html
Patch attached. ChangeLog entry:
2014-08-30 Drew Adams <drew.adams@oracle.com>
* font-lock.el: Respect text property `font-lock-ignore'.
(put-text-property-unless-ignore): New function.
(font-lock-default-unfontify-region): Do not unfontify if
text has property `font-lock-ignore'.
(font-lock-prepend-text-property, font-lock-append-text-property)
(font-lock-fillin-text-property, font-lock-apply-syntactic-highlight)
(font-lock-fontify-syntactically-region, font-lock-apply-highlight)
(font-lock-fontify-anchored-keywords)
(font-lock-fontify-keywords-region):
Use put-text-property-unless-ignore, not put-text-property.
In GNU Emacs 24.4.50.1 (i686-pc-mingw32)
of 2014-08-15 on LEG570
Bzr revision: 117706 rgm@gnu.org-20140815043406-p5hbu97cbm7pulcn
Windowing system distributor `Microsoft Corp.', version 6.1.7601
Configured using:
`configure --enable-checking 'CFLAGS=-O0 -g3' CPPFLAGS=-DGLYPH_DEBUG=1'
[-- Attachment #2: font-lock-2014-08-30.patch --]
[-- Type: application/octet-stream, Size: 13295 bytes --]
diff -c font-lock.el font-lock-patched-2014-08-30.el
*** font-lock.el Sat Aug 30 10:19:26 2014
--- font-lock-patched-2014-08-30.el Sat Aug 30 11:45:52 2014
***************
*** 1236,1249 ****
what properties to clear before refontifying a region.")
(defun font-lock-default-unfontify-region (beg end)
! "Unfontify the text between BEG and END.
! This function is the default `font-lock-unfontify-region-function'."
! (remove-list-of-text-properties
! beg end (append
! font-lock-extra-managed-props
! (if font-lock-syntactic-keywords
! '(syntax-table face font-lock-multiline)
! '(face font-lock-multiline)))))
;; Called when any modification is made to buffer text.
(defun font-lock-after-change-function (beg end &optional old-len)
--- 1236,1254 ----
what properties to clear before refontifying a region.")
(defun font-lock-default-unfontify-region (beg end)
! "Unfontify from BEG to END, except text with property `font-lock-ignore'."
! (let ((here (min beg end))
! (end1 (max beg end))
! chg)
! (while (< here end1)
! (setq chg (next-single-property-change here 'font-lock-ignore nil end1))
! (unless (get-text-property here 'font-lock-ignore)
! (remove-list-of-text-properties
! here chg (append font-lock-extra-managed-props
! (if font-lock-syntactic-keywords
! '(syntax-table face font-lock-multiline)
! '(face font-lock-multiline)))))
! (setq here chg))))
;; Called when any modification is made to buffer text.
(defun font-lock-after-change-function (beg end &optional old-len)
***************
*** 1380,1388 ****
(or (keywordp (car prev))
(memq (car prev) '(foreground-color background-color)))
(setq prev (list prev)))
! (put-text-property start next prop
! (append val (if (listp prev) prev (list prev)))
! object)
(setq start next))))
(defun font-lock-append-text-property (start end prop value &optional object)
--- 1385,1393 ----
(or (keywordp (car prev))
(memq (car prev) '(foreground-color background-color)))
(setq prev (list prev)))
! (put-text-property-unless-ignore start next prop
! (append val (if (listp prev) prev (list prev)))
! object)
(setq start next))))
(defun font-lock-append-text-property (start end prop value &optional object)
***************
*** 1400,1408 ****
(or (keywordp (car prev))
(memq (car prev) '(foreground-color background-color)))
(setq prev (list prev)))
! (put-text-property start next prop
! (append (if (listp prev) prev (list prev)) val)
! object)
(setq start next))))
(defun font-lock-fillin-text-property (start end prop value &optional object)
--- 1405,1413 ----
(or (keywordp (car prev))
(memq (car prev) '(foreground-color background-color)))
(setq prev (list prev)))
! (put-text-property-unless-ignore start next prop
! (append (if (listp prev) prev (list prev)) val)
! object)
(setq start next))))
(defun font-lock-fillin-text-property (start end prop value &optional object)
***************
*** 1413,1419 ****
(let ((start (text-property-any start end prop nil object)) next)
(while start
(setq next (next-single-property-change start prop object end))
! (put-text-property start next prop value object)
(setq start (text-property-any next end prop nil object)))))
;; For completeness: this is to `remove-text-properties' as `put-text-property'
--- 1418,1424 ----
(let ((start (text-property-any start end prop nil object)) next)
(while start
(setq next (next-single-property-change start prop object end))
! (put-text-property-unless-ignore start next prop value object)
(setq start (text-property-any next end prop nil object)))))
;; For completeness: this is to `remove-text-properties' as `put-text-property'
***************
*** 1480,1495 ****
;; still be necessary for other users of syntax-ppss anyway.
(syntax-ppss-after-change-function start)
(cond
! ((not override)
! ;; Cannot override existing fontification.
! (or (text-property-not-all start end 'syntax-table nil)
! (put-text-property start end 'syntax-table value)))
! ((eq override t)
! ;; Override existing fontification.
! (put-text-property start end 'syntax-table value))
! ((eq override 'keep)
! ;; Keep existing fontification.
! (font-lock-fillin-text-property start end 'syntax-table value))))))
(defun font-lock-fontify-syntactic-anchored-keywords (keywords limit)
"Fontify according to KEYWORDS until LIMIT.
--- 1485,1500 ----
;; still be necessary for other users of syntax-ppss anyway.
(syntax-ppss-after-change-function start)
(cond
! ((not override)
! ;; Cannot override existing fontification.
! (or (text-property-not-all start end 'syntax-table nil)
! (put-text-property-unless-ignore start end 'syntax-table value)))
! ((eq override t)
! ;; Override existing fontification.
! (put-text-property-unless-ignore start end 'syntax-table value))
! ((eq override 'keep)
! ;; Keep existing fontification.
! (font-lock-fillin-text-property start end 'syntax-table value))))))
(defun font-lock-fontify-syntactic-anchored-keywords (keywords limit)
"Fontify according to KEYWORDS until LIMIT.
***************
*** 1585,1591 ****
(setq beg (max (nth 8 state) start))
(setq state (parse-partial-sexp (point) end nil nil state
'syntax-table))
! (when face (put-text-property beg (point) 'face face))
(when (and (eq face 'font-lock-comment-face)
(or font-lock-comment-start-skip
comment-start-skip))
--- 1590,1596 ----
(setq beg (max (nth 8 state) start))
(setq state (parse-partial-sexp (point) end nil nil state
'syntax-table))
! (when face (put-text-property-unless-ignore beg (point) 'face face))
(when (and (eq face 'font-lock-comment-face)
(or font-lock-comment-start-skip
comment-start-skip))
***************
*** 1595,1604 ****
(goto-char beg)
(if (looking-at (or font-lock-comment-start-skip
comment-start-skip))
! (put-text-property beg (match-end 0) 'face
font-lock-comment-delimiter-face)))
(if (looking-back comment-end-regexp (point-at-bol) t)
! (put-text-property (match-beginning 0) (point) 'face
font-lock-comment-delimiter-face))))
(< (point) end))
(setq state (parse-partial-sexp (point) end nil nil state
--- 1600,1609 ----
(goto-char beg)
(if (looking-at (or font-lock-comment-start-skip
comment-start-skip))
! (put-text-property-unless-ignore beg (match-end 0) 'face
font-lock-comment-delimiter-face)))
(if (looking-back comment-end-regexp (point-at-bol) t)
! (put-text-property-unless-ignore (match-beginning 0) (point) 'face
font-lock-comment-delimiter-face))))
(< (point) end))
(setq state (parse-partial-sexp (point) end nil nil state
***************
*** 1632,1641 ****
((not override)
;; Cannot override existing fontification.
(or (text-property-not-all start end 'face nil)
! (put-text-property start end 'face val)))
((eq override t)
;; Override existing fontification.
! (put-text-property start end 'face val))
((eq override 'prepend)
;; Prepend to existing fontification.
(font-lock-prepend-text-property start end 'face val))
--- 1637,1646 ----
((not override)
;; Cannot override existing fontification.
(or (text-property-not-all start end 'face nil)
! (put-text-property-unless-ignore start end 'face val)))
((eq override t)
;; Override existing fontification.
! (put-text-property-unless-ignore start end 'face val))
((eq override 'prepend)
;; Prepend to existing fontification.
(font-lock-prepend-text-property start end 'face val))
***************
*** 1661,1671 ****
(when (and font-lock-multiline (>= limit (line-beginning-position 2)))
;; this is a multiline anchored match
;; (setq font-lock-multiline t)
! (put-text-property (if (= limit (line-beginning-position 2))
! (1- limit)
! (min lead-start (point)))
! limit
! 'font-lock-multiline t)))
(save-match-data
;; Find an occurrence of `matcher' before `limit'.
(while (and (< (point) limit)
--- 1666,1676 ----
(when (and font-lock-multiline (>= limit (line-beginning-position 2)))
;; this is a multiline anchored match
;; (setq font-lock-multiline t)
! (put-text-property-unless-ignore (if (= limit (line-beginning-position 2))
! (1- limit)
! (min lead-start (point)))
! limit
! 'font-lock-multiline t)))
(save-match-data
;; Find an occurrence of `matcher' before `limit'.
(while (and (< (point) limit)
***************
*** 1707,1735 ****
(funcall matcher end))
;; Beware empty string matches since they will
;; loop indefinitely.
! (or (> (point) (match-beginning 0))
! (progn (forward-char 1) t)))
! (when (and font-lock-multiline
! (>= (point)
! (save-excursion (goto-char (match-beginning 0))
! (forward-line 1) (point))))
! ;; this is a multiline regexp match
! ;; (setq font-lock-multiline t)
! (put-text-property (if (= (point)
! (save-excursion
! (goto-char (match-beginning 0))
! (forward-line 1) (point)))
! (1- (point))
! (match-beginning 0))
! (point)
! 'font-lock-multiline t))
! ;; Apply each highlight to this instance of `matcher', which may be
! ;; specific highlights or more keywords anchored to `matcher'.
! (setq highlights (cdr keyword))
! (while highlights
! (if (numberp (car (car highlights)))
! (font-lock-apply-highlight (car highlights))
! (set-marker pos (point))
(font-lock-fontify-anchored-keywords (car highlights) end)
;; Ensure forward progress. `pos' is a marker because anchored
;; keyword may add/delete text (this happens e.g. in grep.el).
--- 1712,1738 ----
(funcall matcher end))
;; Beware empty string matches since they will
;; loop indefinitely.
! (or (> (point) (match-beginning 0)) (progn (forward-char 1) t)))
! (when (and font-lock-multiline
! (>= (point) (save-excursion (goto-char (match-beginning 0))
! (forward-line 1) (point))))
! ;; this is a multiline regexp match
! ;; (setq font-lock-multiline t)
! (put-text-property-unless-ignore (if (= (point)
! (save-excursion
! (goto-char (match-beginning 0))
! (forward-line 1) (point)))
! (1- (point))
! (match-beginning 0))
! (point)
! 'font-lock-multiline t))
! ;; Apply each highlight to this instance of `matcher', which may be
! ;; specific highlights or more keywords anchored to `matcher'.
! (setq highlights (cdr keyword))
! (while highlights
! (if (numberp (car (car highlights)))
! (font-lock-apply-highlight (car highlights))
! (set-marker pos (point))
(font-lock-fontify-anchored-keywords (car highlights) end)
;; Ensure forward progress. `pos' is a marker because anchored
;; keyword may add/delete text (this happens e.g. in grep.el).
***************
*** 1742,1747 ****
--- 1745,1761 ----
\f
;; Various functions.
+ (defun put-text-property-unless-ignore (start end property value &optional object)
+ "`put-text-property', but ignore text with property `font-lock-ignore'."
+ (let ((here (min start end))
+ (end1 (max start end))
+ chg)
+ (while (< here end1)
+ (setq chg (next-single-property-change here 'font-lock-ignore object end1))
+ (unless (get-text-property here 'font-lock-ignore object)
+ (put-text-property here chg property value object))
+ (setq here chg))))
+
(defun font-lock-compile-keywords (keywords &optional syntactic-keywords)
"Compile KEYWORDS into the form (t KEYWORDS COMPILED...)
Here each COMPILED is of the form (MATCHER HIGHLIGHT ...) as shown in the
next reply other threads:[~2014-08-30 20:12 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-08-30 20:12 Drew Adams [this message]
2014-08-31 12:47 ` bug#18367: 24.4.50; [PATCH] Text property `font-lock-ignore', to protect from font-lock Stefan Monnier
2014-08-31 15:30 ` Drew Adams
2014-08-31 20:08 ` Stefan Monnier
2014-08-31 20:56 ` Drew Adams
2014-09-01 18:45 ` Wolfgang Jenkner
2014-09-01 19:08 ` Eli Zaretskii
2014-09-01 19:43 ` Wolfgang Jenkner
2014-09-01 20:04 ` Eli Zaretskii
2014-09-30 16:45 ` Michael Heerdegen
2014-09-30 17:14 ` Drew Adams
2015-06-20 16:58 ` Drew Adams
2016-04-30 13:44 ` Lars Ingebrigtsen
2016-04-30 16:32 ` Drew Adams
2016-04-30 14:28 ` Stefan Monnier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=86f1a219-9ab5-439f-85ca-936b942cb034@default \
--to=drew.adams@oracle.com \
--cc=18367@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.