Add yank-handled-properties; use it for `font-lock-face' and `category'

properties, instead of hard-coding these properties' special handling.

* lisp/simple.el (yank-handled-properties): New defcustom.
(yank-excluded-properties): Add font-lock-face and category.
(yank): Doc fix.

* lisp/subr.el (remove-yank-excluded-properties): Obey
yank-handled-properties.  The special handling of font-lock-face
and category is now done this way, instead of being hard-coded.
(insert-for-yank-1): Remove font-lock-face handling.
(yank-handle-font-lock-face-property)
(yank-handle-category-property): New function.

4 files changed, 115 insertions, 82 deletions

diff --git a/etc/NEWS b/etc/NEWS
index a6f6822ab48..fa8a9bd30d0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -160,6 +160,10 @@ The PCL-CVS commands are still available via the keyboard.
 
 * Editing Changes in Emacs 24.3
 
+** New option `yank-handled-properties' allows processing of text
+properties on yanked text, in more ways that are more general than
+just removing them, as done by `yank-excluded-properties'.
+
 ** New option `delete-trailing-lines' specifies whether the M-x
 delete-trailing-whitespace command should delete trailing lines at the
 end of the buffer.  It defaults to t.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 84a8ec18507..ec89b3784d9 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,16 @@
+2012-08-18  Chong Yidong  <cyd@gnu.org>
+
+        * simple.el (yank-handled-properties): New defcustom.
+        (yank-excluded-properties): Add font-lock-face and category.
+        (yank): Doc fix.
+
+        * subr.el (remove-yank-excluded-properties): Obey
+        yank-handled-properties.  The special handling of font-lock-face
+        and category is now done this way, instead of being hard-coded.
+        (insert-for-yank-1): Remove font-lock-face handling.
+        (yank-handle-font-lock-face-property)
+        (yank-handle-category-property): New function.
+
 2012-08-17  Glenn Morris  <rgm@gnu.org>
 
         * mail/rmailout.el (rmail-output-read-file-name):
diff --git a/lisp/simple.el b/lisp/simple.el
index 76243a202bc..1080757f7d2 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3474,16 +3474,36 @@ The argument is used for internal purposes; do not supply one."
 
 ;; Yanking.
 
+(defcustom yank-handled-properties
+  '((font-lock-face . yank-handle-font-lock-face-property)
+    (category . yank-handle-category-property))
+  "List of special text property handling conditions for yanking.
+Each element should have the form (PROP . FUN), where PROP is a
+property symbol and FUN is a function.  When the `yank' command
+inserts text into the buffer, it scans the inserted text for
+stretches of text that have `eq' values of the text property
+PROP; for each such stretch of text, FUN is called with three
+arguments: the property's value in that text, and the start and
+end positions of the text.
+
+This is done prior to removing the properties specified by
+`yank-excluded-properties'."
+  :group 'killing
+  :version "24.3")
+
 ;; This is actually used in subr.el but defcustom does not work there.
 (defcustom yank-excluded-properties
-  '(read-only invisible intangible field mouse-face help-echo local-map keymap
-    yank-handler follow-link fontified)
+  '(category field follow-link fontified font-lock-face help-echo
+    intangible invisible keymap local-map mouse-face read-only
+    yank-handler)
   "Text properties to discard when yanking.
 The value should be a list of text properties to discard or t,
-which means to discard all text properties."
+which means to discard all text properties.
+
+See also `yank-handled-properties'."
   :type '(choice (const :tag "All" t) (repeat symbol))
   :group 'killing
-  :version "22.1")
+  :version "24.3")
 
 (defvar yank-window-start nil)
 (defvar yank-undo-function nil
@@ -3535,15 +3555,16 @@ doc string for `insert-for-yank-1', which see."
 
 (defun yank (&optional arg)
   "Reinsert (\"paste\") the last stretch of killed text.
-More precisely, reinsert the stretch of killed text most recently
-killed OR yanked.  Put point at end, and set mark at beginning.
-With just \\[universal-argument] as argument, same but put point at beginning (and mark at end).
-With argument N, reinsert the Nth most recently killed stretch of killed
-text.
-
-When this command inserts killed text into the buffer, it honors
-`yank-excluded-properties' and `yank-handler' as described in the
-doc string for `insert-for-yank-1', which see.
+More precisely, reinsert the most recent kill, which is the
+stretch of killed text most recently killed OR yanked.  Put point
+at the end, and set mark at the beginning without activating it.
+With just \\[universal-argument] as argument, put point at beginning, and mark at end.
+With argument N, reinsert the Nth most recent kill.
+
+When this command inserts text into the buffer, it honors the
+`yank-handled-properties' and `yank-excluded-properties'
+variables, and the `yank-handler' text property.  See
+`insert-for-yank-1' for details.
 
 See also the command `yank-pop' (\\[yank-pop])."
   (interactive "*P")
diff --git a/lisp/subr.el b/lisp/subr.el
index 1e367a155d0..74afd59f8d5 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2805,35 +2805,24 @@ if it's an autoloaded macro."
 
 ;;;; Support for yanking and text properties.
 
+(defvar yank-handled-properties)
 (defvar yank-excluded-properties)
 
 (defun remove-yank-excluded-properties (start end)
-  "Remove `yank-excluded-properties' between START and END positions.
-Replaces `category' properties with their defined properties."
+  "Process text properties between START and END, inserted for a `yank'.
+Perform the handling specified by `yank-handled-properties', then
+remove properties specified by `yank-excluded-properties'."
   (let ((inhibit-read-only t))
-    ;; Replace any `category' property with the properties it stands
-    ;; for.  This is to remove `mouse-face' properties that are placed
-    ;; on categories in *Help* buffers' buttons.  See
-    ;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
-    ;; for the details.
-    (unless (memq yank-excluded-properties '(t nil))
-      (save-excursion
-        (goto-char start)
-        (while (< (point) end)
-          (let ((cat (get-text-property (point) 'category))
-                run-end)
-            (setq run-end
-                  (next-single-property-change (point) 'category nil end))
-            (when cat
-              (let (run-end2 original)
-                (remove-list-of-text-properties (point) run-end '(category))
-                (while (< (point) run-end)
-                  (setq run-end2 (next-property-change (point) nil run-end))
-                  (setq original (text-properties-at (point)))
-                  (set-text-properties (point) run-end2 (symbol-plist cat))
-                  (add-text-properties (point) run-end2 original)
-                  (goto-char run-end2))))
-            (goto-char run-end)))))
+    (dolist (handler yank-handled-properties)
+      (let ((prop (car handler))
+            (fun  (cdr handler))
+            (run-start start))
+        (while (< run-start end)
+          (let ((value (get-text-property run-start prop))
+                (run-end (next-single-property-change
+                          run-start prop nil end)))
+            (funcall fun value run-start run-end)
+            (setq run-start run-end)))))
     (if (eq yank-excluded-properties t)
         (set-text-properties start end nil)
       (remove-list-of-text-properties start end yank-excluded-properties))))
@@ -2851,29 +2840,31 @@ See `insert-for-yank-1' for more details."
   (insert-for-yank-1 string))
 
 (defun insert-for-yank-1 (string)
-  "Insert STRING at point, stripping some text properties.
-
-Strip text properties from the inserted text according to
-`yank-excluded-properties'.  Otherwise just like (insert STRING).
-
-If STRING has a non-nil `yank-handler' property on the first character,
-the normal insert behavior is modified in various ways.  The value of
-the yank-handler property must be a list with one to four elements
-with the following format:  (FUNCTION PARAM NOEXCLUDE UNDO).
-When FUNCTION is present and non-nil, it is called instead of `insert'
- to insert the string.  FUNCTION takes one argument--the object to insert.
-If PARAM is present and non-nil, it replaces STRING as the object
- passed to FUNCTION (or `insert'); for example, if FUNCTION is
- `yank-rectangle', PARAM may be a list of strings to insert as a
- rectangle.
-If NOEXCLUDE is present and non-nil, the normal removal of the
+  "Insert STRING at point for the `yank' command.
+This function is like `insert', except it honors the variables
+`yank-handled-properties' and `yank-excluded-properties', and the
+`yank-handler' text property.
+
+Properties listed in `yank-handled-properties' are processed,
+then those listed in `yank-excluded-properties' are discarded.
+
+If STRING has a non-nil `yank-handler' property on its first
+character, the normal insert behavior is altered.  The value of
+the `yank-handler' property must be a list of one to four
+elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO).
+FUNCTION, if non-nil, should be a function of one argument, an
+ object to insert; it is called instead of `insert'.
+PARAM, if present and non-nil, replaces STRING as the argument to
+ FUNCTION or `insert'; e.g. if FUNCTION is `yank-rectangle', PARAM
+ may be a list of strings to insert as a rectangle.
+If NOEXCLUDE is present and non-nil, the normal removal of
  `yank-excluded-properties' is not performed; instead FUNCTION is
- responsible for removing those properties.  This may be necessary
- if FUNCTION adjusts point before or after inserting the object.
-If UNDO is present and non-nil, it is a function that will be called
+ responsible for the removal.  This may be necessary if FUNCTION
+ adjusts point before or after inserting the object.
+UNDO, if present and non-nil, should be a function to be called
  by `yank-pop' to undo the insertion of the current object.  It is
- called with two arguments, the start and end of the current region.
- FUNCTION may set `yank-undo-function' to override the UNDO value."
+ given two arguments, the start and end of the region.  FUNCTION
+ may set `yank-undo-function' to override UNDO."
   (let* ((handler (and (stringp string)
                        (get-text-property 0 'yank-handler string)))
          (param (or (nth 1 handler) string))
@@ -2882,7 +2873,7 @@ If UNDO is present and non-nil, it is a function that will be called
          end)
 
     (setq yank-undo-function t)
-    (if (nth 0 handler) ;; FUNCTION
+    (if (nth 0 handler) ; FUNCTION
         (funcall (car handler) param)
       (insert param))
     (setq end (point))
@@ -2891,34 +2882,17 @@ If UNDO is present and non-nil, it is a function that will be called
     ;; following text property changes.
     (setq inhibit-read-only t)
 
-    ;; What should we do with `font-lock-face' properties?
-    (if font-lock-defaults
-        ;; No, just wipe them.
-        (remove-list-of-text-properties opoint end '(font-lock-face))
-      ;; Convert them to `face'.
-      (save-excursion
-        (goto-char opoint)
-        (while (< (point) end)
-          (let ((face (get-text-property (point) 'font-lock-face))
-                run-end)
-            (setq run-end
-                  (next-single-property-change (point) 'font-lock-face nil end))
-            (when face
-              (remove-text-properties (point) run-end '(font-lock-face nil))
-              (put-text-property (point) run-end 'face face))
-            (goto-char run-end)))))
-
-    (unless (nth 2 handler) ;; NOEXCLUDE
-      (remove-yank-excluded-properties opoint (point)))
+    (unless (nth 2 handler) ; NOEXCLUDE
+      (remove-yank-excluded-properties opoint end))
 
     ;; If last inserted char has properties, mark them as rear-nonsticky.
     (if (and (> end opoint)
              (text-properties-at (1- end)))
         (put-text-property (1- end) end 'rear-nonsticky t))
 
-    (if (eq yank-undo-function t)                  ;; not set by FUNCTION
-        (setq yank-undo-function (nth 3 handler))) ;; UNDO
-    (if (nth 4 handler)                            ;; COMMAND
+    (if (eq yank-undo-function t)                  ; not set by FUNCTION
+        (setq yank-undo-function (nth 3 handler))) ; UNDO
+    (if (nth 4 handler)                            ; COMMAND
         (setq this-command (nth 4 handler)))))
 
 (defun insert-buffer-substring-no-properties (buffer &optional start end)
@@ -2944,6 +2918,27 @@ Strip text properties from the inserted text according to
     (insert-buffer-substring buffer start end)
     (remove-yank-excluded-properties opoint (point))))
 
+(defun yank-handle-font-lock-face-property (face start end)
+  "If `font-lock-defaults' is nil, apply FACE as a `face' property.
+START and END denote the start and end of the text to act on.
+Do nothing if FACE is nil."
+  (and face
+       (null font-lock-defaults)
+       (put-text-property start end 'face face)))
+
+;; This removes `mouse-face' properties in *Help* buffer buttons:
+;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
+(defun yank-handle-category-property (category start end)
+  "Apply property category CATEGORY's properties between START and END."
+  (when category
+    (let ((start2 start))
+      (while (< start2 end)
+        (let ((end2     (next-property-change start2 nil end))
+              (original (text-properties-at start2)))
+          (set-text-properties start2 end2 (symbol-plist category))
+          (add-text-properties start2 end2 original)
+          (setq start2 end2))))))
+
 
 ;;;; Synchronous shell commands.