-(defvar egg-mark-list nil)
-(defvar egg-suppress-marking nil)
-
-(defun egg-set-face (beg eng face &optional object)
- (put face 'face face)
- (add-text-properties beg eng
- (list 'category face
- 'egg-face t
- 'modification-hooks '(egg-mark-modification))
- object))
-
-(defun egg-mark-modification (beg end)
- (if (and (null egg-suppress-marking)
- (or (get-text-property beg 'egg-face)
- (setq beg (next-single-property-change beg 'egg-face)))
- (or (get-text-property (1- end) 'egg-face)
- (setq end (previous-single-property-change end 'egg-face)))
- (< beg end))
- (let ((list egg-mark-list)
- (found 0)
- pair mb me b e)
- (add-hook 'post-command-hook 'egg-redraw-face t)
- (setq list egg-mark-list)
- (while (and list (< found 2))
- (setq pair (car list)
- list (cdr list)
- mb (car pair)
- me (cdr pair)
- b (marker-position mb)
- e (marker-position me))
- (cond
- ;; no overwrapping -- SKIP
- ((or (null (eq (marker-buffer mb) (current-buffer)))
- (or (> beg e) (< end b))))
- ;; completely included
- ((and (>= beg b) (<= end e))
- (setq found 3))
- ;; partially overwrapping
- (t
- (set-marker mb nil)
- (set-marker me nil)
- (setq egg-mark-list (delete pair egg-mark-list)
- beg (min beg b)
- end (max end e)
- found (1+ found)))))
- (if (< found 3)
- (progn
- (setq b (make-marker)
- e (make-marker)
- egg-mark-list (cons (cons b e) egg-mark-list))
- (set-marker b beg)
- (set-marker e end))))))
-
-(defun egg-redraw-face ()
- (let ((inhibit-read-only t)
- (inhibit-point-motion-hooks t)
- (egg-suppress-marking t)
- (list egg-mark-list)
- (org-buffer (current-buffer))
- (org-point (point))
- mb me b e p)
- (setq egg-mark-list nil)
- (remove-hook 'post-command-hook 'egg-redraw-face)
- (while list
- (setq mb (car (car list))
- me (cdr (car list))
- list (cdr list))
- (when (marker-buffer mb)
- (set-buffer (marker-buffer mb))
- (let ((before-change-functions nil) (after-change-functions nil))
- (save-restriction
- (widen)
- (setq b (max mb (point-min))
- e (min me (point-max)))
- (set-marker mb nil)
- (set-marker me nil)
- (while (< b e)
- (if (null (get-text-property b 'egg-face))
- (setq b (next-single-property-change b 'egg-face nil e)))
- (setq p (next-single-property-change b 'egg-face nil e))
- (when (< b p)
- (goto-char b)
- (setq str (buffer-substring b p))
- (delete-region b p)
- (remove-text-properties 0 (- p b) '(face) str)
- (insert str)
- (setq b p)))))))
- (set-buffer org-buffer)
- (goto-char org-point)))
-\f