Merge changes from emacs-24; up to 2012-04-26T02:03:19Z!ueno@unixuser.org

[gnu-emacs] / lisp / ansi-color.el

diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 6bc95fa8d9447b73852d9191952c54f1c254c25d..d677f7067041394d530d0a759a0b512336348e31 100644 (file)
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -1,7 +1,6 @@
 ;;; ansi-color.el --- translate ANSI escape sequences into faces
 
 ;;; ansi-color.el --- translate ANSI escape sequences into faces
 

-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2012 Free Software Foundation, Inc.

 
 ;; Author: Alex Schroeder <alex@gnu.org>
 ;; Maintainer: Alex Schroeder <alex@gnu.org>
 
 ;; Author: Alex Schroeder <alex@gnu.org>
 ;; Maintainer: Alex Schroeder <alex@gnu.org>


@@ -69,7 +68,7 @@
 ;;
 ;; Markus Kuhn <Markus.Kuhn@cl.cam.ac.uk> for pointing me to ECMA-48.
 ;;
 ;;
 ;; Markus Kuhn <Markus.Kuhn@cl.cam.ac.uk> for pointing me to ECMA-48.
 ;;

-;; Stefan Monnier <foo@acm.com> explaing obscure font-lock stuff and
+;; Stefan Monnier <foo@acm.com> for explaining obscure font-lock stuff and for

 ;; code suggestions.
 
 \f
 ;; code suggestions.
 
 \f


@@ -91,7 +90,7 @@ as a PDF file <URL:http://www.ecma.ch/ecma1/STAND/ECMA-048.HTM>."
   :group 'processes)
 
 (defcustom ansi-color-faces-vector
   :group 'processes)
 
 (defcustom ansi-color-faces-vector

-  [default bold default italic underline bold bold-italic modeline]
+  [default bold default italic underline success warning error]

   "Faces used for SGR control sequences determining a face.
 This vector holds the faces used for SGR control sequence parameters 0
 to 7.
   "Faces used for SGR control sequences determining a face.
 This vector holds the faces used for SGR control sequence parameters 0
 to 7.


@@ -102,9 +101,9 @@ Parameter  Description        Face used by default
   2        faint              default
   3        italic             italic
   4        underlined         underline
   2        faint              default
   3        italic             italic
   4        underlined         underline

-  5        slowly blinking    bold
-  6        rapidly blinking   bold-italic
-  7        negative image     modeline
+  5        slowly blinking    success
+  6        rapidly blinking   warning
+  7        negative image     error

 
 Note that the symbol `default' is special: It will not be combined
 with the current face.
 
 Note that the symbol `default' is special: It will not be combined
 with the current face.


@@ -133,8 +132,18 @@ Parameter  Color
   37  47   white
 
 This vector is used by `ansi-color-make-color-map' to create a color
   37  47   white
 
 This vector is used by `ansi-color-make-color-map' to create a color

-map.  This color map is stored in the variable `ansi-color-map'."
-  :type '(vector string string string string string string string string)
+map.  This color map is stored in the variable `ansi-color-map'.
+
+Each element may also be a cons cell where the car and cdr specify the
+foreground and background colors, respectively."
+  :type '(vector (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color))
+                 (choice color (cons color color)))

   :set 'ansi-color-map-update
   :initialize 'custom-initialize-default
   :group 'ansi-colors)
   :set 'ansi-color-map-update
   :initialize 'custom-initialize-default
   :group 'ansi-colors)


@@ -174,6 +183,11 @@ in shell buffers.  You set this variable by calling one of:
   :group 'ansi-colors
   :version "23.2")
 
   :group 'ansi-colors
   :version "23.2")
 

+(defvar ansi-color-apply-face-function 'ansi-color-apply-overlay-face
+  "Function for applying an Ansi Color face to text in a buffer.
+This function should accept three arguments: BEG, END, and FACE,
+and it should apply face FACE to the text between BEG and END.")
+

 ;;;###autoload
 (defun ansi-color-for-comint-mode-on ()
   "Set `ansi-color-for-comint-mode' to t."
 ;;;###autoload
 (defun ansi-color-for-comint-mode-on ()
   "Set `ansi-color-for-comint-mode' to t."


@@ -203,8 +217,12 @@ The comint output is assumed to lie between the marker
 `comint-last-output-start' and the process-mark.
 
 This is a good function to put in `comint-output-filter-functions'."
 `comint-last-output-start' and the process-mark.
 
 This is a good function to put in `comint-output-filter-functions'."

-  (let ((start-marker (or comint-last-output-start
-                         (point-min-marker)))
+  (let ((start-marker (if (and (markerp comint-last-output-start)
+                              (eq (marker-buffer comint-last-output-start)
+                                  (current-buffer))
+                              (marker-position comint-last-output-start))
+                         comint-last-output-start
+                       (point-min-marker)))

        (end-marker (process-mark (get-buffer-process (current-buffer)))))
     (cond ((eq ansi-color-for-comint-mode nil))
          ((eq ansi-color-for-comint-mode 'filter)
        (end-marker (process-mark (get-buffer-process (current-buffer)))))
     (cond ((eq ansi-color-for-comint-mode nil))
          ((eq ansi-color-for-comint-mode 'filter)


@@ -212,51 +230,10 @@ This is a good function to put in `comint-output-filter-functions'."
          (t
           (ansi-color-apply-on-region start-marker end-marker)))))
 
          (t
           (ansi-color-apply-on-region start-marker end-marker)))))
 

-(add-hook 'comint-output-filter-functions
-         'ansi-color-process-output)
-
-
-;; Alternative font-lock-unfontify-region-function for Emacs only
-
-(defun ansi-color-unfontify-region (beg end &rest xemacs-stuff)
-  "Replacement function for `font-lock-default-unfontify-region'.
-
-As text properties are implemented using extents in XEmacs, this
-function is probably not needed.  In Emacs, however, things are a bit
-different: When font-lock is active in a buffer, you cannot simply add
-face text properties to the buffer.  Font-lock will remove the face
-text property using `font-lock-unfontify-region-function'.  If you want
-to insert the strings returned by `ansi-color-apply' into such buffers,
-you must set `font-lock-unfontify-region-function' to
-`ansi-color-unfontify-region'.  This function will not remove all face
-text properties unconditionally.  It will keep the face text properties
-if the property `ansi-color' is set.
-
-The region from BEG to END is unfontified.  XEMACS-STUFF is ignored.
-
-A possible way to install this would be:
-
-\(add-hook 'font-lock-mode-hook
-         \(function (lambda ()
-                     \(setq font-lock-unfontify-region-function
-                           'ansi-color-unfontify-region))))"
-  ;; Simplified now that font-lock-unfontify-region uses save-buffer-state.
-  (when (boundp 'font-lock-syntactic-keywords)
-    (remove-text-properties beg end '(syntax-table nil)))
-  ;; instead of just using (remove-text-properties beg end '(face
-  ;; nil)), we find regions with a non-nil face text-property, skip
-  ;; positions with the ansi-color property set, and remove the
-  ;; remaining face text-properties.
-  (while (setq beg (text-property-not-all beg end 'face nil))
-    (setq beg (or (text-property-not-all beg end 'ansi-color t) end))
-    (when (get-text-property beg 'face)
-      (let ((end-face (or (text-property-any beg end 'face nil)
-                         end)))
-       (remove-text-properties beg end-face '(face nil))
-       (setq beg end-face)))))
+(defalias 'ansi-color-unfontify-region 'font-lock-default-unfontify-region)
+(make-obsolete 'ansi-color-unfontify-region "not needed any more" "24.1")

 
 ;; Working with strings
 
 ;; Working with strings

-

 (defvar ansi-color-context nil
   "Context saved between two calls to `ansi-color-apply'.
 This is a list of the form (FACES FRAGMENT) or nil.  FACES is a list of
 (defvar ansi-color-context nil
   "Context saved between two calls to `ansi-color-apply'.
 This is a list of the form (FACES FRAGMENT) or nil.  FACES is a list of


@@ -290,9 +267,7 @@ This function can be added to `comint-preoutput-filter-functions'."
            (setq fragment (substring string pos)
                  result (concat result (substring string start pos))))
        (setq result (concat result (substring string start))))
            (setq fragment (substring string pos)
                  result (concat result (substring string start pos))))
        (setq result (concat result (substring string start))))

-      (if fragment
-         (setq ansi-color-context (list nil fragment))
-       (setq ansi-color-context nil)))
+      (setq ansi-color-context (if fragment (list nil fragment))))

     result))
 
 (defun ansi-color-apply (string)
     result))
 
 (defun ansi-color-apply (string)


@@ -309,10 +284,7 @@ Every call to this function will set and use the buffer-local variable
 This information will be used for the next call to `ansi-color-apply'.
 Set `ansi-color-context' to nil if you don't want this.
 
 This information will be used for the next call to `ansi-color-apply'.
 Set `ansi-color-context' to nil if you don't want this.
 

-This function can be added to `comint-preoutput-filter-functions'.
-
-You cannot insert the strings returned into buffers using font-lock.
-See `ansi-color-unfontify-region' for a way around this."
+This function can be added to `comint-preoutput-filter-functions'."

   (let ((face (car ansi-color-context))
        (start 0) end escape-sequence result
        colorized-substring)
   (let ((face (car ansi-color-context))
        (start 0) end escape-sequence result
        colorized-substring)


@@ -325,8 +297,7 @@ See `ansi-color-unfontify-region' for a way around this."
       (setq escape-sequence (match-string 1 string))
       ;; Colorize the old block from start to end using old face.
       (when face
       (setq escape-sequence (match-string 1 string))
       ;; Colorize the old block from start to end using old face.
       (when face

-       (put-text-property start end 'ansi-color t string)
-       (put-text-property start end 'face face string))
+       (put-text-property start end 'font-lock-face face string))

       (setq colorized-substring (substring string start end)
            start (match-end 0))
       ;; Eliminate unrecognized ANSI sequences.
       (setq colorized-substring (substring string start end)
            start (match-end 0))
       ;; Eliminate unrecognized ANSI sequences.


@@ -338,8 +309,7 @@ See `ansi-color-unfontify-region' for a way around this."
       (setq face (ansi-color-apply-sequence escape-sequence face)))
     ;; if the rest of the string should have a face, put it there
     (when face
       (setq face (ansi-color-apply-sequence escape-sequence face)))
     ;; if the rest of the string should have a face, put it there
     (when face

-      (put-text-property start (length string) 'ansi-color t string)
-      (put-text-property start (length string) 'face face string))
+      (put-text-property start (length string) 'font-lock-face face string))

     ;; save context, add the remainder of the string to the result
     (let (fragment)
       (if (string-match "\033" string start)
     ;; save context, add the remainder of the string to the result
     (let (fragment)
       (if (string-match "\033" string start)


@@ -347,9 +317,7 @@ See `ansi-color-unfontify-region' for a way around this."
            (setq fragment (substring string pos))
            (push (substring string start pos) result))
        (push (substring string start) result))
            (setq fragment (substring string pos))
            (push (substring string start pos) result))
        (push (substring string start) result))

-      (if (or face fragment)
-         (setq ansi-color-context (list face fragment))
-       (setq ansi-color-context nil)))
+      (setq ansi-color-context (if (or face fragment) (list face fragment))))

     (apply 'concat (nreverse result))))
 
 ;; Working with regions
     (apply 'concat (nreverse result))))
 
 ;; Working with regions


@@ -417,10 +385,9 @@ start of the region and set the face with which to start.  Set
       ;; Find the next SGR sequence.
       (while (re-search-forward ansi-color-regexp end-marker t)
        ;; Colorize the old block from start to end using old face.
       ;; Find the next SGR sequence.
       (while (re-search-forward ansi-color-regexp end-marker t)
        ;; Colorize the old block from start to end using old face.

-       (when face
-         (ansi-color-set-extent-face
-          (ansi-color-make-extent start-marker (match-beginning 0))
-          face))
+       (funcall ansi-color-apply-face-function
+                start-marker (match-beginning 0)
+                face)

         ;; store escape sequence and new start position
         (setq escape-sequence (match-string 1)
              start-marker (copy-marker (match-end 0)))
         ;; store escape sequence and new start position
         (setq escape-sequence (match-string 1)
              start-marker (copy-marker (match-end 0)))


@@ -433,25 +400,26 @@ start of the region and set the face with which to start.  Set
       (if (re-search-forward "\033" end-marker t)
          (progn
            ;; if the rest of the region should have a face, put it there
       (if (re-search-forward "\033" end-marker t)
          (progn
            ;; if the rest of the region should have a face, put it there

-           (when face
-             (ansi-color-set-extent-face
-              (ansi-color-make-extent start-marker (point))
-              face))
+           (funcall ansi-color-apply-face-function
+                    start-marker (point) face)

            ;; save face and point
            (setq ansi-color-context-region
                  (list face (copy-marker (match-beginning 0)))))
        ;; if the rest of the region should have a face, put it there
            ;; save face and point
            (setq ansi-color-context-region
                  (list face (copy-marker (match-beginning 0)))))
        ;; if the rest of the region should have a face, put it there

-       (if face
-           (progn
-             (ansi-color-set-extent-face
-              (ansi-color-make-extent start-marker end-marker)
-              face)
-             (setq ansi-color-context-region (list face)))
-         ;; reset context
-         (setq ansi-color-context-region nil))))))
+       (funcall ansi-color-apply-face-function
+                start-marker end-marker face)
+       (setq ansi-color-context-region (if face (list face)))))))
+
+(defun ansi-color-apply-overlay-face (beg end face)
+  "Make an overlay from BEG to END, and apply face FACE.
+If FACE is nil, do nothing."
+  (when face
+    (ansi-color-set-extent-face
+     (ansi-color-make-extent beg end)
+     face)))

 
 ;; This function helps you look for overlapping overlays.  This is
 
 ;; This function helps you look for overlapping overlays.  This is

-;; usefull in comint-buffers.  Overlapping overlays should not happen!
+;; useful in comint-buffers.  Overlapping overlays should not happen!

 ;; A possible cause for bugs are the markers.  If you create an overlay
 ;; up to the end of the region, then that end might coincide with the
 ;; process-mark.  As text is added BEFORE the process-mark, the overlay
 ;; A possible cause for bugs are the markers.  If you create an overlay
 ;; up to the end of the region, then that end might coincide with the
 ;; process-mark.  As text is added BEFORE the process-mark, the overlay


@@ -576,7 +544,8 @@ The face definitions are based upon the variables
     (mapc
      (function (lambda (e)
                  (aset ansi-color-map index
     (mapc
      (function (lambda (e)
                  (aset ansi-color-map index

-                      (ansi-color-make-face 'foreground e))
+                      (ansi-color-make-face 'foreground
+                                             (if (consp e) (car e) e)))

                  (setq index (1+ index)) ))
      ansi-color-names-vector)
     ;; background attributes
                  (setq index (1+ index)) ))
      ansi-color-names-vector)
     ;; background attributes


@@ -584,7 +553,8 @@ The face definitions are based upon the variables
     (mapc
      (function (lambda (e)
                  (aset ansi-color-map index
     (mapc
      (function (lambda (e)
                  (aset ansi-color-map index

-                      (ansi-color-make-face 'background e))
+                      (ansi-color-make-face 'background
+                                             (if (consp e) (cdr e) e)))

                  (setq index (1+ index)) ))
      ansi-color-names-vector)
     ansi-color-map))
                  (setq index (1+ index)) ))
      ansi-color-names-vector)
     ansi-color-map))


@@ -621,7 +591,7 @@ ANSI-CODE is used as an index into the vector."
   "Create a new face by applying all the parameters in ESCAPE-SEQ.
 
 Should any of the parameters result in the default face (usually this is
   "Create a new face by applying all the parameters in ESCAPE-SEQ.
 
 Should any of the parameters result in the default face (usually this is

-the parameter 0), then the effect of all previous parameters is cancelled.
+the parameter 0), then the effect of all previous parameters is canceled.

 
 ESCAPE-SEQ is a SGR control sequences such as \\033[34m.  The parameter
 34 is used by `ansi-color-get-face-1' to return a face definition."
 
 ESCAPE-SEQ is a SGR control sequences such as \\033[34m.  The parameter
 34 is used by `ansi-color-get-face-1' to return a face definition."


@@ -641,5 +611,4 @@ ESCAPE-SEQ is a SGR control sequences such as \\033[34m.  The parameter
 
 (provide 'ansi-color)
 
 
 (provide 'ansi-color)
 

-;; arch-tag: 00726118-9432-44fd-b72d-d2af7591c99c

 ;;; ansi-color.el ends here
 ;;; ansi-color.el ends here