[xyzzy:04680] Re: text-attribute の検索

[YAMAMOTO Shinji <sinj@xxxxxxxxxxxx>]

亀井さん、こんにちは。山本です。

  In message "[xyzzy:04679] Re: text-attribute の検索"
  KAMEI Tetsuya <kamei@xxxxxxxxxxxx> wrote:

> | それを言ったら、変更もですけど。^^;
> 
> 要ります?

あ、いえ特には。^^;

# ちなみに、この前から遊んでいたのを貼り付けておきます。
# www-mode にくっつけて服部さんに投げたものですが、
# 興味がある人は、てきとーに遊んで下さい。


;;;
;;; overlay.l
;;;
;;;  (let* ((overlay (create-overlay
;;;			(create-overlay-attr :bold t
;;;					     :underline t
;;;					     :foreground 3)
;;;			(create-overlay-attr :foreground 1)))
;;;         (tag (cons 'overlay (cons overlay 'hoge))))
;;;    (set-text-attribute start end tag)
;;;    (overlay-set-atty tag t))
;;;

(provide "overlay")

(defstruct
  (overlay-attr (:constructor create-overlay-attr
	      (&key bold underline strike-out foreground background prefix extend)))
  bold
  underline
  strike-out
  foreground
  background
  prefix
  extend)

(defstruct
  (overlay (:constructor create-overlay (on off)))
  on
  off)

(defvar *last-overlay-marker* nil)


(defun overlay-set-attr (tag &optional off)
  (let ((tattr (if off
		   (overlay-off (cadr tag))
		 (overlay-on (cadr tag)))))
    (let ((bold (overlay-attr-bold tattr))
	  (underline (overlay-attr-underline tattr))
	  (strike-out (overlay-attr-strike-out tattr))
	  (foreground (overlay-attr-foreground tattr))
	  (background (overlay-attr-background tattr))
	  (prefix (overlay-attr-prefix tattr))
	  (extend (overlay-attr-extend tattr)))
      (setq *last-overlay-marker* (cons (make-marker) tag))
      (apply #'modify-text-attributes tag
	     (append (and bold (list ':bold bold))
		     (and underline (list ':underline underline))
		     (and strike-out (list ':strike-out strike-out))
		     (and foreground (list ':foreground foreground))
		     (and background (list ':background background))
		     (and prefix (list ':prefix prefix))
		     (and extend (list ':extend extend))
		     (list ':test #'equal))))))

(defun overlay-handler ()
  (when (and *last-overlay-marker*
	     (null (minibuffer-window-p (selected-window))))
    (let ((obuf (selected-buffer)))
      (set-buffer (marker-buffer (car *last-overlay-marker*)))
      (overlay-set-attr (cdr *last-overlay-marker*) t)
      (setq *last-overlay-marker* nil)
      (set-buffer obuf)))
  (let ((point (point))
	start end tag)
    (cond ((multiple-value-bind (from to tg)
	       (find-text-attribute 'overlay :end point :from-end t :test #'eq
				    :key #'(lambda (x) (and (consp x) (car x))))
	     (if (and from (<= from point) (> to point))
		 (setq start from end to tag tg))))
	  ((multiple-value-bind (from to tg)
	       (find-text-attribute 'overlay :start point :test #'eq
				    :key #'(lambda (x) (and (consp x) (car x))))
	     (if (and from (<= from point) (>= to point))
		 (setq start from end to tag tg)))))
    (if start
	(overlay-set-attr tag))))


;(delete-hook '*post-command-hook* 'overlay-handler)
(add-hook '*post-command-hook* 'overlay-handler)


-- 
山本真二           sinj@xxxxxxxxxxxx