* lisp/man.el (Man-overstrike-face, Man-underline-face)

(Man-reverse-face): Remove variables.
(Man-overstrike, Man-underline, Man-reverse): New faces.
(Man-fontify-manpage): Use them instead of the variables.
(Man-cleanup-manpage): Comment change.
(Man-ansi-color-map): New variable.
(Man-fontify-manpage): Use it.
Call ansi-color-apply-on-region to replace ad hoc code.

Fixes: debbugs:12147

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 824c0e2601b78a132cd0727f16964adf777cc353..00da55a24fe4a232558f0898a063dce02653b16b 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,14 @@
 2012-08-15  Wolfgang Jenkner  <wjenkner@inode.at>
 
+       * man.el (Man-overstrike-face, Man-underline-face)
+       (Man-reverse-face): Remove variables.
+       (Man-overstrike, Man-underline, Man-reverse): New faces.
+       (Man-fontify-manpage): Use them instead of the variables.
+       (Man-cleanup-manpage): Comment change.
+       (Man-ansi-color-map): New variable.
+       (Man-fontify-manpage): Use it.
+       Call ansi-color-apply-on-region to replace ad hoc code (bug#12147).
+
        Implement ANSI SGR parameters 22-27 (bug#12146).
        * ansi-color.el (ansi-colors): Doc fix.
        (ansi-color-context, ansi-color-context-region): Doc fix.

diff --git a/lisp/man.el b/lisp/man.el
index 6b1b9dc042ab29537b2983f1ce75915354007315..36f8061d18f7325e782b4796edac08244adf9478 100644 (file)
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -88,6 +88,7 @@
 \f
 ;;; Code:
 
+(require 'ansi-color)
 (require 'button)
 
 (defgroup man nil
@@ -124,20 +125,29 @@ the manpage buffer."
   :type 'boolean
   :group 'man)
 
-(defcustom Man-overstrike-face 'bold
+(defface Man-overstrike
+  '((t (:inherit bold)))
   "Face to use when fontifying overstrike."
-  :type 'face
-  :group 'man)
+  :group 'man
+  :version "24.2")
 
-(defcustom Man-underline-face 'underline
+(defface Man-underline
+  '((t (:inherit underline)))
   "Face to use when fontifying underlining."
-  :type 'face
-  :group 'man)
+  :group 'man
+  :version "24.2")
 
-(defcustom Man-reverse-face 'highlight
+(defface Man-reverse
+  '((t (:inherit highlight)))
   "Face to use when fontifying reverse video."
-  :type 'face
-  :group 'man)
+  :group 'man
+  :version "24.2")
+
+(defvar Man-ansi-color-map (let ((ansi-color-faces-vector
+                                 [ default Man-overstrike default Man-underline
+                                   Man-underline default default Man-reverse ]))
+                            (ansi-color-make-color-map))
+  "The value used here for `ansi-color-map'.")
 
 ;; Use the value of the obsolete user option Man-notify, if set.
 (defcustom Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly)
@@ -962,7 +972,6 @@ Return the buffer in which the manpage will appear."
                               Man-width)
                              (Man-width (frame-width))
                              ((window-width))))))
-       (setenv "GROFF_NO_SGR" "1")
        ;; Since man-db 2.4.3-1, man writes plain text with no escape
        ;; sequences when stdout is not a tty.  In 2.5.0, the following
        ;; env-var was added to allow control of this (see Debian Bug#340673).
@@ -1050,38 +1059,12 @@ Same for the ANSI bold and normal escape sequences."
   (message "Please wait: formatting the %s man page..." Man-arguments)
   (goto-char (point-min))
   ;; Fontify ANSI escapes.
-  (let ((faces nil)
-       (buffer-undo-list t)
-       (start (point)))
-    ;; http://www.isthe.com/chongo/tech/comp/ansi_escapes.html
-    ;; suggests many codes, but we only handle:
-    ;; ESC [ 00 m      reset to normal display
-    ;; ESC [ 01 m      bold
-    ;; ESC [ 04 m      underline
-    ;; ESC [ 07 m      reverse-video
-    ;; ESC [ 22 m      no-bold
-    ;; ESC [ 24 m      no-underline
-    ;; ESC [ 27 m      no-reverse-video
-    (while (re-search-forward "\e\\[0?\\([1470]\\|2\\([247]\\)\\)m" nil t)
-      (if faces (put-text-property start (match-beginning 0) 'face
-                                  (if (cdr faces) faces (car faces))))
-      (setq faces
-           (cond
-            ((match-beginning 2)
-             (delq (pcase (char-after (match-beginning 2))
-                     (?2 Man-overstrike-face)
-                     (?4 Man-underline-face)
-                     (?7 Man-reverse-face))
-                   faces))
-            ((eq (char-after (match-beginning 1)) ?0) nil)
-            (t
-             (cons (pcase (char-after (match-beginning 1))
-                     (?1 Man-overstrike-face)
-                     (?4 Man-underline-face)
-                     (?7 Man-reverse-face))
-                   faces))))
-      (delete-region (match-beginning 0) (match-end 0))
-      (setq start (point))))
+  (let ((ansi-color-apply-face-function
+        (lambda (beg end face)
+          (when face
+            (put-text-property beg end 'face face))))
+       (ansi-color-map Man-ansi-color-map))
+    (ansi-color-apply-on-region (point-min) (point-max)))
   ;; Other highlighting.
   (let ((buffer-undo-list t))
     (if (< (buffer-size) (position-bytes (point-max)))
@@ -1090,23 +1073,23 @@ Same for the ANSI bold and normal escape sequences."
          (goto-char (point-min))
          (while (search-forward "__\b\b" nil t)
            (backward-delete-char 4)
-           (put-text-property (point) (1+ (point)) 'face Man-underline-face))
+           (put-text-property (point) (1+ (point)) 'face 'Man-underline))
          (goto-char (point-min))
          (while (search-forward "\b\b__" nil t)
            (backward-delete-char 4)
-           (put-text-property (1- (point)) (point) 'face Man-underline-face))))
+           (put-text-property (1- (point)) (point) 'face 'Man-underline))))
     (goto-char (point-min))
     (while (search-forward "_\b" nil t)
       (backward-delete-char 2)
-      (put-text-property (point) (1+ (point)) 'face Man-underline-face))
+      (put-text-property (point) (1+ (point)) 'face 'Man-underline))
     (goto-char (point-min))
     (while (search-forward "\b_" nil t)
       (backward-delete-char 2)
-      (put-text-property (1- (point)) (point) 'face Man-underline-face))
+      (put-text-property (1- (point)) (point) 'face 'Man-underline))
     (goto-char (point-min))
     (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t)
       (replace-match "\\1")
-      (put-text-property (1- (point)) (point) 'face Man-overstrike-face))
+      (put-text-property (1- (point)) (point) 'face 'Man-overstrike))
     (goto-char (point-min))
     (while (re-search-forward "o\b\\+\\|\\+\bo" nil t)
       (replace-match "o")
@@ -1117,7 +1100,7 @@ Same for the ANSI bold and normal escape sequences."
       (put-text-property (1- (point)) (point) 'face 'bold))
     ;; When the header is longer than the manpage name, groff tries to
     ;; condense it to a shorter line interspersed with ^H.  Remove ^H with
-    ;; their preceding chars (but don't put Man-overstrike-face).  (Bug#5566)
+    ;; their preceding chars (but don't put Man-overstrike).  (Bug#5566)
     (goto-char (point-min))
     (while (re-search-forward ".\b" nil t) (backward-delete-char 2))
     (goto-char (point-min))
@@ -1128,7 +1111,7 @@ Same for the ANSI bold and normal escape sequences."
     (while (re-search-forward Man-heading-regexp nil t)
       (put-text-property (match-beginning 0)
                         (match-end 0)
-                        'face Man-overstrike-face)))
+                        'face 'Man-overstrike)))
   (message "%s man page formatted" (Man-page-from-arguments Man-arguments)))
 
 (defun Man-highlight-references (&optional xref-man-type)
@@ -1211,7 +1194,7 @@ script would have done them."
   (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+"))
   ;; When the header is longer than the manpage name, groff tries to
   ;; condense it to a shorter line interspersed with ^H.  Remove ^H with
-  ;; their preceding chars (but don't put Man-overstrike-face).  (Bug#5566)
+  ;; their preceding chars (but don't put Man-overstrike).  (Bug#5566)
   (goto-char (point-min))
   (while (re-search-forward ".\b" nil t) (backward-delete-char 2))
   (Man-softhyphen-to-minus)