;; copyright 2004 russell young (emacs@young-0.com)
;; Color-Select mode: This is a major mode that allows for editing
;; text and marking it up dynamically with different faces. 
;;
;; It currently supports two different ways of marking up text, with
;; hooks for adding more. The provided ways are:
;; 
;;  - tags: an internal method which inserts tags into the file when
;;  it is saved, allowing the coloring to be reconstructed. Selections
;;  can be marked dynamically by using X-selection and
;;  dynamically-defined keys. Tags can be kept in a special internal
;;  format, or else by using XML. See CS-TAG-XML.
;;
;;  - regexps: marks up all text matching a given regular expression
;;
;; To add more, you need at least a coloring function and uncoloring
;; function - see CS-TAGGED for an example. If you want to be able to
;; edit the new type in the edit buffer you will need several edit
;; functions defined as well. Again, see the existing functions
;; CS-TAGGED and CS-REGEXP as examples.
;;
;; The information necessary to reconstruct the coloring is stored in
;; file-local variables, which are written automatically when the file
;; is written and then silently deleted so as not to interfere with
;; the desired contents. If you want to add any other file-local
;; variables, add the symbol to the list CS-SAVE-VARS and it will be
;; saved when the file is written.
;;
;; TO USE:

;; Edit a file and type "M-x cs-mode". This will put the buffer in cs
;; mode. The simplest way to color is to make an X-selection and type
;; ^C-[0-9] (depending on the number of faces defined.) This will mark
;; the selection with the chosen face.
;;
;; To edit the faces type ^C-e to open the edit buffer. This will
;; allow you to view all registered faces and edit or delete them,
;; depending on the type. Currently there are 2 types registered:
;; tagged regions, which you select as above, and regex regions, which
;; you can add in the face editor.

(require 'cl)
(defvar cs-file-locals t
  "Controls whether file local variables should be written when the buffer is saved")

(defvar cs-registered '(cs-tagged cs-regexp))

(defvar cs-save-vars '(cs-save-vars cs-types cs-tag-used cs-tag-xml)
  "These variables are saved as file-local variables. Others can be
added, but these ones are required.")

(defvar is-cs-mode nil "internal use")
(defvar cs-mode-hook ())
(defvar cs-tag-used "\001")

(setq cs-types '((cs-tagged default) 
				 (cs-tagged bold)
				 (cs-tagged underline)
				 (cs-tagged scroll-bar)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Main functions to set up the mode
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun cs-mode ()
  (interactive)
  (let ((init (mapcar 'symbol-value cs-save-vars))
		(vars cs-save-vars)
		(buffer-read-only nil)
		(orig (buffer-modified-p)))
	(kill-all-local-variables)
	(make-variable-buffer-local 'is-cs-mode)
	(make-variable-buffer-local 'cs-mode-hook)
	(setq is-cs-mode t)
	(if (or (not cs-file-locals) (interactive-p))
		(mapcar 'make-variable-buffer-local cs-save-vars)
	  (mapcar* 'set vars init))
	(cs-keymap)
	(setq mode-name "CS")
	(setq major-mode 'cs-mode)
	;; this forces init after all the local variables have been processed.
	;; Otherwise local variable initialization can cause problems.
	(or (interactive-p) (setq find-file-hooks (cons 'cs-auto-init find-file-hooks)))
	(add-hook 'write-contents-hooks 'cs-save-buffer)
	(run-hooks 'cs-mode-hook)
	(or orig (set-buffer-modified-p nil)))
  )

(defun cs-repaint ()
  (interactive)
  (let ((orig (buffer-modified-p))
		(point (point))
		)
	(cs-check-tag)
	(cs-colorize nil)
	(put-text-property 1 (point-max) 'face nil)
	(cs-colorize t)
	(cs-keymap)
	(or orig (set-buffer-modified-p nil))
	(goto-char point)
	))

(defun cs-colorize (on)
  "Turns the color on or off in the buffer
This is needed to save the buffer, or to repaint it. Colorings
and uncolorings are called in reverse order, coloring in the
order listed in the edit buffer. So, ant tags that come before 
REs will be overwritten, but tags coming after REs will take 
precedence."
  (let ((orig (buffer-modified-p))
		which list command diff)
	(if on (setq command 'color
				 which -1
				 diff 1
				 list cs-types)
	  (setq command 'decolor
			diff -1
			which (length cs-types)
			list (reverse cs-types)))
	(mapcar (lambda (x) (apply (car x) command (setq which (+ diff which)) (cdr x))) list)
	(or orig (set-buffer-modified-p nil))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions to save and read the file, along with its
;; coloring
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun cs-save-buffer ()
  (if cs-file-locals
	  (let ((write-contents-hooks nil)
			(buffer-read-only nil)
			(point (point))
			end)
		(cs-colorize nil)
		(setq end (point-max))
		(cs-put-locals)
		(basic-save-buffer)
		(delete-region end (point-max))
		(cs-colorize t)
		(set-buffer-modified-p nil)
		(goto-char point)
		t)))

(defun cs-auto-init ()
  (setq find-file-hooks (cdr find-file-hooks))
  (let ((point (point))
		(orig (buffer-modified-p)))
	(goto-char (point-max))
	(if (re-search-backward "\n;;; Local Variables: \\*\\*\\*" nil t)
		(delete-region (match-beginning 0) (point-max)))
	(cs-colorize t)
	(goto-char point)
	(or orig (set-buffer-modified-p nil)))
  )

(defun cs-put-locals ()
  (goto-char (point-max))
  (insert "\n;;; Local Variables: ***\n")
  (mapcar (lambda (x) (insert (format ";;; %s: %s ***\n" x (stringify (symbol-value x)))))
		  cs-save-vars)
  (insert ";;; mode: " mode-name " ***\n")
  (insert ";;; End: ***\n")
  )

(defun unquote-\\ (str)
  "READ-FROM-MINIBUFFER escapes \\, which makes entering regexps tricky.
This unescapes them."
  (let ((result "")
		(ptr 0)
		(p 0))
	(while (setq p (string-match "\\([^\\]*\\\\\\)\\\\" str ptr))
	  (setq result (concat result (match-string 1 str))
			ptr (+ p (- (match-end 0) (match-beginning 0)))))
	(concat result (substring str ptr))))

(defun redo-\\ (x)
  (string-match "^[^\\]*" x)
  (let* ((result (match-string 0 x))
		 (ptr (match-end 0)))
	(while (string-match "\\\\[^\\]*" x ptr)
	  (setq result (concat result "\\" (match-string 0 x))
			ptr (match-end 0)))
	result))

(defun stringify (x)
  (cond ((number-or-marker-p x) (number-to-string x))
		((char-or-string-p x) (concat "\"" (redo-\\ x) "\""))
		((not x) "nil")
		((symbolp x) (symbol-name x))
		((listp x) (concat "(" (mapconcat 'stringify x " ") ")"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; These functions allow editing of the active faces. 
;; These are the general functions, each type needs some
;; of its own specialized functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar cs-edit-buffer "*Edit faces*")
(defvar cs-parent nil "internal use")

(defun cs-edit-faces (&optional parent pos command)
  (interactive)
  (let* ((syms cs-save-vars)
		 (values (mapcar 'symbol-value syms))
		 (buffer (or cs-parent (and is-cs-mode (current-buffer))))
		 (which -1)
		 line)
	(if parent
		(setq cs-parent parent)
	  (if (= 1 (count-windows))
		  (split-window-vertically))
	  (other-window 1)
	  (switch-to-buffer (get-buffer-create cs-edit-buffer))
	  (make-variable-buffer-local 'cs-parent)
	  (setq cs-parent buffer)
	  (mapcar* (lambda (x y) (make-variable-buffer-local x) (set x y))
			   syms values))
	(setq buffer-read-only nil)
	(erase-buffer)
	(insert "CURRENT FACES:\n-------------------\n")
	(mapcar (lambda (x) (funcall x 'add)) cs-registered)
	(insert "\n")
	(mapcar (lambda (x) (apply (car x) 'edit (setq which (1+ which)) (cdr x))) cs-types)
	(if pos (cs-goto-which pos command)
	  (goto-char 1)
	  (cs-edit-next))
	(use-local-map (cs-edit-map))
	(setq buffer-read-only t)))

(defun cs-goto-which (which command)
  "Puts the cursor at a particular command when the edit buffer is redisplayed"
  (let ((pt 1))
	(while (and (setq pt (next-single-property-change pt 'which))
				(not (equal (get-text-property pt 'which) which))))
	(if pt 
		(while (and (setq pt (next-single-property-change pt 'command))
					(not (equal (get-text-property pt 'command) command)))))
	(and pt (goto-char pt))))

(defun cs-edit-map ()
  "Creates the map for markup-mode"
  (let ((map (make-sparse-keymap)))
	(define-key map '[return] 'cs-edit-command)
	(define-key map "\t" 'cs-edit-next)
	(define-key map '[up] (lambda () (interactive) (cs-arrow-line t)))
	(define-key map '[left] 'cs-edit-prev)
	(define-key map '[down] 'cs-arrow-line)
	(define-key map '[right] 'cs-edit-next)
	(define-key map '[C-tab] 'cs-edit-prev)
	(define-key map "q" (lambda () (interactive) (kill-buffer nil)))
	map))


(defun cs-arrow-line (&optional back)
  "Moves cursor to the next line (down arrow)"
  (interactive)
  (condition-case nil	
	  (let ((mv (if back -1 1)))
		(line-move mv)
		(backward-char mv))
	(beginning-of-buffer (goto-char (point-max)))
	(end-of-buffer (goto-char 1)))
  (if back (cs-edit-prev) (cs-edit-next)))

(defun cs-edit-next ()
  "Moves cursor to the next field (tab)"
  (interactive)
  (goto-char (or (next-single-property-change (point) 'tab)
				 (next-single-property-change 1 'tab)))
  (or (get-text-property (point) 'tab) (cs-edit-next)))

(defun cs-edit-prev ()
  "Moves cursor to the previous field (C-tab)"
  (interactive)
  (goto-char (or (previous-single-property-change (point) 'tab)
				 (previous-single-property-change (point-max) 'tab)))
  (and (get-text-property (1- (point)) 'tab) (cs-edit-prev)))

(defun cs-edit-command ()
  "Executes the command associated with the current buffer location
Command text have a COMMAND property associated with them, which is 
called to get the action."
  (interactive)
  (let* ((which (get-text-property (point) 'which))
		 (command (get-text-property (point) 'command)))
	(if command
		(when (and (setq which (funcall command which))
				   cs-parent)
		  (cs-edit-faces cs-parent which command)
		  (with-current-buffer cs-parent
			(set-buffer-modified-p t)
			(cs-repaint)))
	  (beep))))

(defun cs-read-face ()
  (let* ((face (completing-read "Choose face: " (mapcar (lambda (x) (list (symbol-name x)))	(face-list))
								nil t)))
	(if (equal face "") nil (intern face))))
  
(defun cs-edit-up (which &optional down)
  "Moves the selected face up or down in the list"
  (interactive)
  (or down (setq which (1- which)))
  (when (and (>= which 0) (< which (1- (length cs-types))))
	(swap cs-types which)
	(if cs-parent 
		(let ((types cs-types))
		  (with-current-buffer cs-parent
			(setq cs-types types))))
	which))

(defun swap (list position &optional noerror)
  "exchange the position of 2 items in a list"
  (if (< (1+ position) (length list))
	  (let ((temp (nth position list)))
		(setf (nth position list) (nth (1+ position) list)
			  (nth (1+ position) list) temp)
		list)
	(or noerror (error "Location too large"))))

(defun cs-edit-down (which)
  "Moves the selected face down in the list"
  (interactive)
  (cs-edit-up which t)
  (if (>= (setq which (1+ which)) (length cs-types)) (1- (length cs-types)) which))

(defun cs-edit-delete (which)
  "Deletes the selected face from the list of markup faces"
  (let* ((desc (nth which cs-types)))
	(when (y-or-n-p (format "Really delete (%s %s)? " (car desc) (second desc)))
	  (setf (nthcdr which cs-types) (nthcdr (1+ which) cs-types))
	  (if cs-parent 
		  (let ((types cs-types))
			(with-current-buffer cs-parent
			  (setq cs-types types)
			  (cs-repaint)
			  (set-buffer-modified-p t))))
	  (if (>= which (length cs-types)) (1- (length cs-types)) which))))

(defun cs-edit-change-face (which)
  "Changes the face used to display the text designated by this entry"
  (let ((face (cs-read-face)))
	(when face
	  (setf (second (nth which cs-types)) face)
	  which)))

(defun cs-make-field (text &rest props)
  "Makes a text field with tab, and any other desired properties"
  ;;; boy this bug took me a while to figure out. Some faces are DEFCONST. In these
  ;;; cases it would break here.
  (if (cl-const-expr-p text) (setq text (format "%s" text)))
  (mapcar (lambda (x) (put-text-property 0 (length text) (car x) (cdr x) text)) (cons '(tab . t) props))
  text)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; These are the functions to implement tagged coloring
;; To use add an element similar to the following to the
;; CS-TYPES list:
;;
;; (cs-tag 'face)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar cs-tag "\001"
  "Tag to use as a base for the marker for different faces")
(defvar cs-add-char "\001"
  "If the default tag already occurs in the text it would cause problems.
Continue to add this string to the tag until the actual tag used does
not appear in the text." )

(defun cs-check-tag ()
  "Checks to make sure that the color tag does not already occur in the file
If it does this changes the base tag in CS-TYPES to match."
  (goto-char 1)
  (if (re-search-forward cs-tag-used nil t)
	  (error (format "tag \"%s\" exists in file, please change CS-TAG-USED" cs-tag-used))))

(defun cs-tagged (command &optional which face tag)
  "function to allow setting the face of X selected region
To use add to CS-TYPES an element of the form:
    (cs-tagged TAG EXTEND-TAG)
where TAG is a string to use as a tag, and EXTEND-TAG is a string
that is repeatedly appended to TAG until the combination does
not occur elsewhere in the file."
  (let* ((desc (if which (nth which cs-types)))
		 (buffer-read-only nil)
		 (orig (buffer-modified-p))
		 (point (point)))
	(case command
	  ('color (goto-char (+ point (cs-tagged-on which desc))))
	  ('decolor (goto-char (+ point (cs-tagged-off which desc))))
	  ('add  (insert "\t" (cs-make-field "Add tagged face" '(command . cs-edit-add-tag)) "\n"))
	  ('edit (cs-tag-insert-one-line which)))
	(or orig (set-buffer-modified-p nil))))

(defun cs-tagged-on (which desc)
  "Does the work to replace tags with faces in the file"
  (if cs-tag-xml (cs-xml-on which)
	(let* ((re (format "%s_%s_\\([0-9]+\\)_" cs-tag-used which))
		   (adjust 0))
	  (goto-char 1)
	  (while (re-search-forward re nil t)
		(put-text-property (match-end 0) (+ (match-end 0) (string-to-number (match-string 1))) 
						   'face (second desc))
		(setq adjust (- adjust (- (match-end 0) (match-beginning 0))))
		(delete-region (match-beginning 0) (match-end 0))
		)
	  adjust))
  )

(defun cs-tagged-off (which desc)
  "Inserts tags to mark the faces in the current file"
  (if cs-tag-xml (cs-xml-off which)
	(let* ((pt 1)
		   (adjust 0)
		   (tmplt (concat cs-tag-used "_%s_%s_"))
		   (target-face (second desc))
		   (face nil))
	  (goto-char 1)
	  (while (> (point-max) (point))
		(setq pt (next-char-property-change (point))
			  face (get-text-property (point) 'face))
		(if (not (equal face target-face))
			(setq face "")
		  (put-text-property (point) pt 'face nil)
		  (insert (setq face (format tmplt which (- pt (point))))))
		(goto-char (+ (length face) pt))
		(setq adjust (+ adjust (length face))))
	  adjust)
	))

(defun cs-set-selected-face (face)
  "adds a face to the selection"
  (interactive)
  (let* ((selection (x-get-selection))
		 (range (if (or (re-search-forward (concat "\\=" selection) nil t)
						(re-search-backward (concat selection "\\=") nil t))
					(match-data 0))))
	(if range
		(put-text-property (car range) (second range) 'face face))))

(defun cs-make-key (map key face)
  (define-key map (format "\003%c" key) `(lambda () (interactive) (cs-set-selected-face (quote ,face)))))

(defun cs-keymap ()
  "Makes function key definitions for the tagged faces."
  (let ((map (make-sparse-keymap))
		(key (1- ?0)))
	(define-key map "\003r" 'cs-repaint)
	(define-key map "\003e" 'cs-edit-faces)
	(condition-case nil
		(mapcar (lambda (x) (if (equal (car x) 'cs-tagged)
								(if (>= key ?9)
									(throw 'full nil)
								  (cs-make-key map (setq key (1+ key)) (second x)))))
				cs-types)
	  (full))
	(use-local-map map)))

;; editing functions
(defun cs-edit-add-tag (&optional ignore)
  (interactive)
  (let* ((face (cs-read-face))
		 types)
	(when face
	  (setq cs-types (cons (list 'cs-tagged face) cs-types)
			types cs-types)
	  (if cs-parent
		  (with-current-buffer cs-parent
			(setq cs-types types)
			(set-buffer-modified-p t))))
	t))

;; For building the edit buffer
(defun cs-tag-insert-one-line (which) 
  (let* ((desc (nth which cs-types))
		 (face (second desc))
		 (insert (format "\tTAG %s %s %s %-20s\n" 
						 (cs-make-field "Up" '(command . cs-edit-up))
						 (cs-make-field "Dn" '(command . cs-edit-down))
						 (cs-make-field "Del" '(command . cs-edit-delete))
						 (cs-make-field (format "%s" face) '(command . cs-edit-change-face) (cons 'face face)))))
	(put-text-property 0 (length insert) 'which which insert)
	(insert insert)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Bonus: added function to colorize RE
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; There are hooks that allow other ways of coloring text. This is an
;; example that sets the color of all text matching a given regexp.
;; More regexps can be matched with different faces by adding to the
;; list CS-COLOR-RES. The format is (FACE RE &optional WHICH), where
;; FACE is the face to use, RE is the regexp to match, and WHICH if
;; given says only color the given subexpression.

(make-face 'cs-reverse-face)
(set-face-background 'cs-reverse-face "white")
(set-face-foreground 'cs-reverse-face "black")

(defvar cs-re-faces ())

(defun cs-setup-regexp ()
  (or (member 'cs-re-faces cs-save-vars)
	  (setq cs-save-vars (cons 'cs-re-faces cs-save-vars))))

(defun cs-regexp (command &optional which face regexp subexp case)
  (case command
	('color (cs-regexp-colorize face regexp subexp case))
	('decolor (cs-regexp-colorize nil regexp subexp case))
	('add (insert "\t" (cs-make-field "Add regexp face" '(command . cs-regexp-add)) "\n"))
	('edit (cs-regexp-insert-one-line which))
	))

(defun cs-regexp-colorize (face regexp subexp case)
  (let ((point (point))
		(case-fold-search (not case)))
	(goto-char 1)
	(while (re-search-forward regexp nil t)
	  (put-text-property (match-beginning subexp) (match-end subexp) 'face face))
	(goto-char point)))
  
(defun cs-regexp-insert-one-line (which) 
  (let* ((desc (nth which cs-types))
		 (face (second desc))
		 (regexp (third desc))
		 (insert (format "\tRE  %s %s %s %-20s %s %s\n" 
						 (cs-make-field "Up" '(command . cs-edit-up))
						 (cs-make-field "Dn" '(command . cs-edit-down))
						 (cs-make-field "Del" '(command . cs-edit-delete))
						 (cs-make-field (symbol-name face) '(command . cs-edit-change-face) (cons 'face face))
						 (cs-make-field (redo-\\ regexp) '(command . cs-edit-regexp))
						 (fourth desc))))
	(put-text-property 0 (length insert) 'which which insert)
	(insert insert)))

(defun cs-edit-regexp(which)
  (let* ((desc (nth which cs-types))
		 (new-regexp (unquote-\\ (read-from-minibuffer "Edit regexp: " (redo-\\ (third desc)))))
		 (new-subexp (string-to-number (read-from-minibuffer "Subexpression: " (number-to-string (fourth desc))))))
	(setf (third desc) new-regexp)
	(setf (fourth desc) new-subexp))
  which)

(defun cs-regexp-add(&optional face regexp which case)
  (interactive)
  (when (or face (setq face (cs-read-face)))
	(or regexp (setq regexp (unquote-\\ (read-from-minibuffer "Enter regexp: "))))
	(if (string-match "^\\\\C" regexp)
		(setq case t
			  regexp (substring regexp 2)))
	(or which (setq which (string-to-number (read-from-minibuffer "(optional) enter subexpression: "))))
	(cs-setup-regexp)
	(setq cs-types (cons (list 'cs-regexp face regexp which case) cs-types))
	(if cs-parent
		(let ((types cs-types))
		  (with-current-buffer cs-parent
			(setq cs-types types))))
	0))

(defun cs-regexp-get-curr ()
  (if (re-search-forward "\"\\(.*\\)\" [0-9]" (line-end-position) t)
	  (let* ((regexp (unquote-\\ (match-string 1)))
			 (entry (some (lambda (x) (if (equal (third x) regexp) x)) cs-types)))
		(if entry (- (length cs-types) (length (member entry cs-types)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; XML tagging
;;
;; This is kind of half a mode. It implements tagging 
;; just like above, but uses XML tags instead of the internal
;; tags used above. It just replaces the rendering and 
;; unrendering functions in the same calls.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar cs-tag-xml nil
;(defvar cs-tag-xml "markup"
  "use internal tags or XML tags")

(defun cs-xml-on (which)
  "Replacement coloring function for CS-mode to use XML tags to mark colored regions"
  (let* ((adjust 0)
		 (desc (nth which cs-types))
		 (face (second desc))
		 (open-re (format "<%s face=\"%s\">" cs-tag-xml face))
		 (close-re (format "</%s>" cs-tag-xml))
		 (len (+ (length open-re) (length close-re)))
		 point)
	(goto-char 1)
	(while (re-search-forward open-re nil t)
	  (setq	point (match-beginning 0))
	  (delete-region point (match-end 0))
	  (or (re-search-forward close-re nil t)
		  (error (format "Missing closing tag for \"%s\"" face)))
	  (put-text-property point (point) 'face face)
	  (delete-region (match-beginning 0) (match-end 0))
	  (setq adjust (- adjust len)))
	adjust))

(defun cs-find-next (pt property value match)
  (while (and (setq pt (next-char-property-change pt))
			  (> (point-max) pt)
			  (if (equal (get-text-property pt property) value)
				  (not match)
				match)))
  (and (> (point-max) pt) pt))

(defun cs-xml-off (which)
  "Replacement uncoloring function for CS-mode to use XML tags to mark colored regions"
  (let* ((pt 1)
		 (desc (nth which cs-types))
		 (adjust 0)
		 (face (second desc))
		 (open-tag (format "<%s face=\"%s\">" cs-tag-xml face))
		 (close-tag (concat "</" cs-tag-xml ">"))
		 (len (+ (length open-tag) (length close-tag))))
	(while (setq pt (cs-find-next pt 'face face t))
	  (goto-char pt)
	  (insert open-tag)
	  (setq pt (point))
	  (goto-char (or (setq end (cs-find-next (point) 'face face nil))
					 (error (format "No closing tag for %s" open-tag))))
	  (put-text-property pt (point) 'face nil)
	  (insert close-tag)
	  (setq adjust (+ adjust len)
			pt (point)))
	adjust))

(provide 'color-select)