;;; man.el --- browse UNIX manual pages
;; Keywords: help

;; Copyright (C) 1985, 1993, 1994, 1996, 1997 Free Software Foundation, Inc.
;;
;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; This file defines "manual-entry", and the remaining definitions all
;; begin with "Manual-".  This makes the autocompletion on "M-x man" work.
;;
;; Eviscerated 26-Jun-96 by Jamie Zawinski <jwz@jwz.org>.
;; All that stuff about looking at $MANPATH and building up lists of
;; directories was bullshit.  Now we just invoke "man" and format the
;; output, end of story.
;;
;; [ older changelog entries removed, since they're all about code that
;;   I've deleted. ]

(defgroup man nil
  "Browse Unix manual pages"
  :group 'help)

(defcustom Manual-program "man" "\
*Name of the program to invoke in order to format the source man pages."
  :type 'string
  :group 'man)

(defcustom Manual-buffer-view-mode t "\
*Whether manual buffers should be placed in view-mode.
nil means leave the buffer in fundamental-mode in another window.
t means use `view-buffer' to display the man page in the current window.
Any other value means use `view-buffer-other-window'."
  :type '(radio (const :tag "Fundamental-mode other window" nil)
		(const :tag "View-mode current window" t)
		(sexp :format "%t\n" :tag "View-mode other window" other))
  :group 'man)

(defcustom Manual-switches nil
  "*List of switches to the man program."
  :type '(choice (const :tag "none" nil) 
                 (repeat (string :tag "switch"))) 
  :group 'man)

(defcustom Manual-mode-hook nil
  "*Function or functions run on entry to Manual-mode."
  :type 'hook
  :group 'man)

(defvar Manual-page-history nil "\
A list of names of previously visited man page buffers.")

(defvar Manual-page-minibuffer-history nil "\
Minibuffer completion history for `manual-entry'.")

;; New variables.

(defcustom Manual-snip-subchapter
  (not (search "solaris" system-configuration))
  "*Should man look in chapter 3 for ctime(3c)?
This is relevant for Solaris and, perhaps, other systems which have
`man -s 3' not find things in chapter 3c, or other such sub-chapters"
  :type 'boolean
  :group 'man)

(defface man-italic '((t (:italic t)))
  "Manual italics face"
  :group 'man)
(set-face-parent 'man-italic 'italic nil '(default))

(defface man-bold '((t (:bold t)))
  "Manual bold face"
  :group 'man)
(set-face-parent 'man-bold 'bold nil '(default))

(defface man-heading '((t (:bold t)))
  "Manual headings face"
  :group 'man)
(set-face-parent 'man-heading 'bold nil '(default))

(defface man-cross-reference '((t (:underline t)))
  "Manual cross-reference face"
  :group 'man)
(set-face-parent 'man-cross-reference 'underline nil '(default))

;; XEmacs; this variable name doesn't fit with our naming convention, but does
;; fit with that of GNU, retained for compatibility of init files.
(defcustom Man-width nil
  "Number of columns for which manual pages should be formatted.

If nil, use the width of the window from where `manual-entry' was invoked.
If non-nil, use the width of the frame where the manpage is displayed.
The value also can be a positive integer for a fixed width.

See also `Man-width-max'."
  :type '(choice (const :tag "Window width" nil)
                 (const :tag "Frame width" t)
                 (integer :tag "Fixed width" :value 65))
  :group 'man)

;; XEmacs; GNU default to 80 with this, frustrating the code's attempt to pass
;; the window-system frame width down to the man process in order to get
;; appropriate use of screen real estate.
(defcustom Man-width-max nil
  "Maximum number of columns allowed for the width of manual pages.
It defines the maximum width for the case when `Man-width' is customized
to a dynamically calculated value depending on the frame/window width.
If the width calculated for `Man-width' is larger than the maximum width,
it will be automatically reduced to the width defined by this variable.
When nil, there is no limit on maximum width."
  :type '(choice (const :tag "No limit" nil)
                 (integer :tag "Max width" :value 80))
  :group 'man)

(defvar Manual-mode-map
  (let ((m (make-sparse-keymap)))
    (set-keymap-name m 'Manual-mode-map)
    ;; See the entertainment in #'Manual-mode-and-display-buffer about this
    ;; key binding:
    (define-key m "l" 'Manual-last-page)
    (define-key m 'button2 'Manual-follow-cross-reference)
    (define-key m 'button3 'Manual-popup-menu)
    m))

(defvar Manual-mode-cross-reference-map
  (let ((m (make-sparse-keymap)))
    (set-keymap-parents m Manual-mode-map)
    (define-key m "\C-m" 'Manual-follow-cross-reference)
    (define-key m 'button1 'Manual-follow-cross-reference)
    m))

(defvar Manual-mode-syntax-table nil
  "Syntax table used in Manual-mode buffers")
(unless Manual-mode-syntax-table
  (setq Manual-mode-syntax-table (make-syntax-table))
  (modify-syntax-entry ?: "_" Manual-mode-syntax-table)
  (modify-syntax-entry ?+ "." Manual-mode-syntax-table)
  (modify-syntax-entry ?- "." Manual-mode-syntax-table)
  (modify-syntax-entry ?/ "." Manual-mode-syntax-table)
  (modify-syntax-entry ?* "." Manual-mode-syntax-table))

(defun Manual-unicode-to-char (fixnum)
  "Limited compatibility version of `unicode-to-char'.

Falls back to `decode-char' with a `ucs' first argument if that is available;
otherwise uses those Greek and CJK characters available within every Mule
emacs to represent typographical and other non-ASCII characters
emulated by troff using backspace composition.

Note that several of the characters needed have no equivalent in those XEmacs
versions where any Unicode support is provided by the mule-ucs package."
  (let (acons)
    (cond
      ((< fixnum #x100) (int-char fixnum))
      ((and (fboundp 'decode-char) (decode-char 'ucs fixnum)))
      ((and
        (setq acons (assq fixnum '((#x0398 greek-iso8859-7 72)
                                   (#x03a6 greek-iso8859-7 86)
                                   (#x03a7 greek-iso8859-7 87)
                                   (#x03b6 greek-iso8859-7 102)
                                   (#x03b8 greek-iso8859-7 104)
                                   (#x03bb greek-iso8859-7 107)
                                   (#x03be greek-iso8859-7 110)
                                   (#x03c0 greek-iso8859-7 112)
                                   (#x03c3 greek-iso8859-7 115)
                                   (#x03c4 greek-iso8859-7 116)
                                   (#x03c8 greek-iso8859-7 120)
                                   (#x2020 japanese-jisx0208 34 119)
                                   (#x2021 japanese-jisx0208 34 120)
                                   (#x2022 chinese-big5-1 33 38)
                                   (#x2200 japanese-jisx0208 34 79)
                                   (#x2191 japanese-jisx0208 34 44)
                                   (#x2193 japanese-jisx0208 34 45)
                                   (#x222b japanese-jisx0208 34 105)
                                   (#x222b japanese-jisx0208 34 105)
                                   (#x2286 japanese-jisx0208 34 60)
                                   (#x2286 japanese-jisx0208 34 60)
                                   (#x2287 japanese-jisx0208 34 61)
                                   (#x2287 japanese-jisx0208 34 61)
                                   (#x2295 chinese-cns11643-1 34 83)
                                   (#x0444 cyrillic-iso8859-5 100))))
        (featurep 'mule)
        (apply #'make-char (cdr acons))))
      ;; For the last no-mule user in the world, at least transform bullets to
      ;; something readable:
      ((cdr (assq fixnum
                  (load-time-value
                   (acons #x2022 (let ((extent (make-extent 0 1 "o")))
                                   (set-extent-face extent 'man-bold)
                                   (set-extent-property extent 'duplicable t)
                                   (set-extent-property extent 'unique t)
                                   (extent-object extent)) nil))))))))

(defun Manual-process-filter (process string &optional flush)
  "Handle process output from PROCESS, started from `manual-entry'.

STRING reflects the most recent output from PROCESS. FLUSH, if supplied,
indicates thaat `Manual-process-filter' should not save any data from STRING
for processing on its next call.

This function does four broad things:

1. It interprets the tty sequences for underline, removes them, and applies
   the `man-italic' face to the associated text.
2. It interprets the tty sequences for overstriking with the same character,
   removes them, and applies the `man-bold' face to the associated text.
3. It interprets other groff sequences with backspace to construct accented
   characters and other non-ASCII characters, and transforms them to the
   appropriate XEmacs character.
4. It sets up cross-references to other man pages, which can be followed by
   right clicking or by hitting `return'.

In addition, the first time it is called for a given PROCESS, it tells XEmacs
to display the buffer; see `Manual-buffer-view-mode'."
  (let* ((buffer (process-buffer process))
         (process-mark (process-mark process))
         (length (length string))
         (last 0)
	 position character-before character-after stashed extent lookup
	 extent-start-position displayp)
    (defvar #123456=#:Manual-stashed-strings nil)
    (with-current-buffer buffer
      (save-excursion
        (macrolet
            ;; The first four of these are macros rather than inline labels
            ;; because the macro approach will actually lead to inline code on
            ;; 21.4, whereas code with #'labels won't. 
            ((character-after (position)
               `((lambda (position)
		   (incf position)
		   (if (< position length) (aref string position))) ,position))
             (character-before (position)
               `((lambda (position)
		   (decf position)
		   (if (>= position 0)
		       (if (< position length)
			   (aref string position))
		     (char-after (+ (point) position)))) ,position))
	     (stash-string (string)
               ;; This was implemented initially as a property of
               ;; PROCESS. Unfortunately this doesn't work on 21.4. Then I
               ;; implemented it as a buffer-local variable; unfortunately
               ;; this doesn't work for the first stashed string, we have a
               ;; longstanding bug in the first use of buffer local
               ;; variables. An alist is cheap and portable.
               `(setq #123456# (cons (cons process ,string)
                           (delete* process #123456# :key #'car))))
	     (get-stashed-string ()
               `(prog1
                   (cdr (assq process #123456#))
                 (setq #123456# (delete* process #123456# :key #'car))))
	     (adjust-or-make-extent (face-name extent-end-position
                                               fail-early-unless)
	       `(if (and ,fail-early-unless
                         (setf extent (extent-at extent-start-position
                                                 buffer 'face nil
                                                 'before))
                     (eq ,face-name (extent-face extent)))
                     (prog1 extent (setf (extent-end-position extent)
                                         ,extent-end-position))
		 (prog1 (setf extent (make-extent extent-start-position
						  ,extent-end-position
						  buffer))
		   (setf (extent-face extent) ,face-name))))
             (cond-with-handlers (&rest clauses &environment env)
               (cons 'cond
                     (loop for clause in clauses
                           collect (if (assq (car-safe clause) env)
                                       (macroexpand clause env)
                                     clause))))
	     (try-two-character-sequence (first second output)
	       `((and (eql character-before ,first) (eql character-after
						     ,second)
                      (load-time-value (Manual-unicode-to-char ,output)))
		 (insert (substring string last position))
		 (delete-region (1- (point)) (point))
		 (insert (load-time-value (Manual-unicode-to-char ,output)))
		 (incf position 2)
		 (setf last position)))
	     (try-two-characters-with-table (first alist)
	       `((and (eql character-before ,first) character-after
		      (setf lookup
                            (assq character-after
                                  (load-time-value
                                   (mapcan #'(lambda (cons)
                                               (let ((character
                                                      (Manual-unicode-to-char
                                                       (cdr cons))))
                                                 (if character
                                                     `((,(car cons) .
                                                        ,character)))))
                                           ,alist)))))
		 (insert (substring string last position))
		 (delete-region (1- (point)) (point))
		 (insert (cdr lookup))
		 (incf position 2)
		 (setf last position)))
             (try-compose-map (first map)
               `((and (eql character-before ,first) character-after
                      (fboundp ',map)
                      (setf lookup (lookup-key ',map character-after)))
                 (insert (substring string last position))
                 (delete-region (1- (point)) (point))
                 (insert
                  (if (consp (aref lookup 0))
                      (car (aref lookup 0))
                    (event-to-character
                     (make-event 'key-press `(key ,(aref lookup 0)))
                     nil nil t)))
                 (incf position 2)
                 (setf last position))))
          (if (marker-buffer process-mark)
              (goto-char process-mark)
            (set-marker process-mark (point) buffer))
          (when (eql (point) (point-min))
            (setq displayp t))
	  (when (setf stashed (get-stashed-string))
	    (let ((position 2))
              (symbol-macrolet ((do-not-end-with
                                    ;; These make it more likely we would have
                                    ;; to stash the end of the concatted
                                    ;; string.
                                    '(?\b ?_ ?| ?+)))
                (while (and (< position length)
                            (or (member* (aref string position)
                                         do-not-end-with)
                                (member* (aref string (1- position))
                                         do-not-end-with)))
                  (incf position)))
	      (setf position (min (1+ position) length))
	      (Manual-process-filter process
				     (concat stashed
					     (substring string 0 position))
                                     flush)
	      (setf last (- position (length
				      (setf stashed (get-stashed-string)))))
	      (goto-char process-mark)))
          (setf buffer-read-only nil)
          (while (setf position (position ?\b string :start last :end length))
            (cond-with-handlers
              ((eql (setf character-before (character-before position))
		    (setf character-after (character-after position)))
	       ;; Bold, implemented in the TTY as overstriking with the same
	       ;; character.
	       (insert (substring string last position))
	       (setf extent-start-position (1- (point)))
	       (incf position 2)
	       (while (and (< position length)
			   (eql (setf character-before (aref string position))
				(setf character-after
				      (character-after (1+ position))))
			   (eql (aref string (1+ position)) ?\b))
		 (insert character-before)
		 (incf position 3))
	       ;; We don't have extra code to handle overstriking multiple
	       ;; times; that's fine, the loop with #'position above does
	       ;; that implicitly.
	       (setf extent (adjust-or-make-extent
			     'man-bold (point)
			     (eql (character-before
				   (- position
				      (* 3 (- (point) extent-start-position))
				      1))
				  ?\b))
		     last position))
              ((and (eql character-before ?_) character-after)
	       ;; Underline; treat as italic
	       (insert (substring string last position))
	       ;; We do insert-and-delete rather than substring the inserted
	       ;; string because that interacts better with stashed strings.
	       (delete-region (1- (point)) (point))
	       (setf extent-start-position (point))
	       (insert character-after)
	       (incf position 2)
	       (while (and (< position length)
			   (eql (aref string position) ?_)
			   (eql (character-after position) ?\b)
			   (setf character-after
				 (character-after (1+ position))))
		 (insert character-after)
		 (incf position 3))
	       ;; Manual-nuke-nroff-bs used to worry about the ambiguity of
	       ;; _\b_. This code treats it as bold--it usually is
	       ;; bold--unless it is preceded immediately by italic
	       ;; characters. This gives reasonable results.
	       (setf extent (adjust-or-make-extent
			     'man-italic (point)
			     (eql (character-before
				   (- position
				      (* 3 (- (point) extent-start-position))
				      1))
				  ?\b))
		     last position))
              ((and (eql character-after ?\b) character-before
		    (eql character-before (character-after (1+ position))))
		;; Bolded CJK double-width characters.
               (insert (substring string last position))
               (setf extent-start-position (1- (point)))
	       (setf extent (adjust-or-make-extent
			     'man-italic (point)
			     (eql (character-before
				   (- position
				      (* 3 (- (point) extent-start-position))
				      1))
				  ?\b))
                     position (+ position 3)
		     last position))
	      ;; From here onwards we're dealing with attempts of groff
	      ;; -mtty-char to create non-ASCII characters using ASCII
	      ;; primitives and overstriking. If troff has been invoked
	      ;; using -Tutf8 and if we understand UTF-8 none of the below
	      ;; will apply, and the code will never execute, absent corrupt
	      ;; data, because the first three clauses will have matched, so
	      ;; its performance impact is minimal.
	      (try-two-character-sequence ?+ ?o #x2022) ;; Bullet
	      (try-two-characters-with-table
	       ?| '((?^ . #x2191)   ;; Uparrow
		    (?v . #x2193)   ;; Downarrow
		    (?- . #x2020)   ;; Dagger
		    (?= . #x2021)   ;; Double dagger
		    (?u . #x03C8)   ;; Psi
		    (?o . #x0444))) ;; Phi; use lowercase CYRILLIC SMALL
				    ;; LETTER EF, to force a glyph without a
				    ;; loop.
              (try-compose-map ?\" compose-diaeresis-map)
	      (try-two-character-sequence ?\" ?_ #x030b)
              (try-compose-map ?' compose-acute-map)
	      (try-two-character-sequence ?' ?\` #x0306)
	      ((and (eql character-before ?')
		    (eql character-after ?,)
		    (eql (character-after (1+ position)) ?\b)
		    (eql (character-after (+ position 2)) ?I)
                    (load-time-value (Manual-unicode-to-char #x222b)))
 	       (insert (substring string last position))
 	       (delete-region (1- (point)) (point)) 
               (insert (load-time-value (Manual-unicode-to-char #x222b)))
 	       (incf position 4)
 	       (setf last position))
              (try-compose-map ?^ compose-circumflex-map)
              (try-compose-map ?` compose-grave-map)
              ((and (eql character-before ?`)
		    (eql character-after ?')
                    (eql (character-after (+ position 1)) ?\b)
                    (eql (character-after (+ position 2)) ?o))
 	       (insert (substring string last position))
 	       (delete-region (1- (point)) (point))
               (insert ?\xf0) ;; eth
 	       (incf position 4)
 	       (setf last position))
              (try-compose-map ?~ compose-tilde-map)
	      (try-two-characters-with-table
	       ?~ '((?_ . #xAC)     ;; Logical not
		    (?t . #x03c4))) ;; Tau
              (try-compose-map ?v compose-caron-map)
              (try-compose-map ?/ compose-stroke-map)
	      (try-two-characters-with-table
	       ?/ '((?E . #x2209)   ;; NOT AN ELEMENT OF
		    (?c . #xa2)))   ;; CENT SIGN
              (try-two-characters-with-table
	       ?, '((?C . #x03b6)   ;; Zeta
		    (?E . #x03be)   ;; GREEK SMALL LETTER XI
		    (?c . #xe7)     ;; LATIN SMALL LETTER C WITH CEDILLA
		    (?f . #x0192)   ;; LATIN SMALL LETTER F WITH HOOK
		    (?i . #xa1)     ;; INVERTED EXCLAMATION MARK
		    (?u . #xb5)))   ;; MICRO SIGN
	      (try-two-characters-with-table
	       ?- '((?0 . #x03B8)   ;; GREEK SMALL LETTER THETA
		    (?D . #xd0)     ;; LATIN CAPITAL LETTER ETH
		    (?L . #xa3)     ;; POUND SIGN (sterling, that is)
		    (?O . #x0398)   ;; GREEK CAPITAL LETTER THETA
		    (?V . #x2200)   ;; FOR ALL
		    (?n . #x03C0)   ;; GREEK SMALL LETTER PI
		    (?o . #x03C3)   ;; GREEK SMALL LETTER SIGMA
		    (?w . #x03D6))) ;; GREEK PI SYMBOL
	      (try-two-characters-with-table
	       ?o '((?A . #xc5)     ;; LATIN CAPITAL LETTER A WITH RING ABOVE
		    (?a . #xea)     ;; LATIN SMALL LETTER E WITH CIRCUMFLEX
		    (?x . #xa4)))   ;; CURRENCY SIGN
	      (try-two-characters-with-table
	       ?= '((?Y . #xa5)     ;; YEN SIGN
		    (?v . #x21d3)   ;; DOWNWARDS DOUBLE ARROW
		    (?^ . #x21d1))) ;; UPWARDS DOUBLE ARROW
              ((and (eql character-before ?=)
		    (eql character-after ?_)
		    (eql (character-before (1- position)) ?\()
                    (load-time-value (Manual-unicode-to-char #x2286)))
 	       (insert (substring string last position))
 	       (delete-region (- (point) 2) (point))
               ;; Reflex subset
               (insert (load-time-value (Manual-unicode-to-char #x2286)))
 	       (incf position 2)
 	       (setf last position))
              ((and (eql character-before ?=)
		    (eql character-after ?_)
		    (eql (character-after (1+ position)) ?\))
                    (load-time-value (Manual-unicode-to-char #x2287)))
 	       (insert (substring string last position))
 	       (delete-region (1- (point)) (point))
               ;; Reflex superset
               (insert (load-time-value (Manual-unicode-to-char #x2287)))
 	       (incf position 3)
 	       (setf last position))
	      (try-two-character-sequence ?p ?b #xfe)
	      (try-two-characters-with-table
	       ?I '((?b . #xde)
		    (?O . #x03a6)
		    (?Y . #x03a7)))
	      (try-two-character-sequence ?> ?\\ #x03bb) ;; lambda
	      (try-two-characters-with-table
	       ?O '((?x . #x2297)    ;; CIRCLED TIMES
		    (?+ . #x2295)))  ;; CIRCLED PLUS
              ((and (>= (+ position 3) length) (not flush))
	       (stash-string (substring string position))
	       (setf length position))
	       ;; Let the clean-up below insert the trailing piece of the
	       ;; string.
	      (t
	       (incf position)
               (insert (substring string last position))
	       (setf last position))))
	  (if (< last length) (insert (substring string last length)))
          (goto-char process-mark)
          (if (member "-k"
                      ;; #'process-command doesn't cons, to my surprise, no
                      ;; point saving whether this is an apropos or real
                      ;; man(1) call.
                      (process-command process))
              (progn
                (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t)
                  (forward-char -2)
                  (delete-region (point) (1- (point))))
                (goto-char process-mark))
            (if (eql (point) (point-min))
                (progn
                  ;; Treat the first line as a heading.
                  (set-extent-face (make-extent (point) (point-at-eol))
                                   'man-heading)
                  ;; Some of the Perl module man pages have ridiculously long
                  ;; titles, which groff chokes on for the title line,
                  ;; emitting backspaces with the intention of rubbing out an
                  ;; already-printed character. Handle that.
                  (while (re-search-forward "[^\b]\b" (point-at-eol) t)
                    (delete-region (match-beginning 0) (match-end 0)))
                  ;; Skip the top line of manual pages, but not apropos
                  ;; listings.
                  (forward-line 1))
              ;; Zap ESC7,  ESC8, and ESC9
              ;; This is for Sun man pages like "man 1 csh"
              (backward-char)
              (while (re-search-forward "\e[789]" nil t)
                (delete-region (match-beginning 0) (point)))
              (goto-char process-mark)))
          (if (position ?\) string :end length) ;; Can a cross-reference have
						;; ended in the text we just
						;; inserted?
              (Manual-mouseify-cross-references (point) (point-max)))
          (setf (marker-position process-mark) (point-max)
                buffer-read-only t
                (buffer-modified-p buffer) nil)
          (when displayp (Manual-mode-and-display-buffer buffer)))))))

(defun Manual-boldface-section-titles ()
  "Mark subsection header lines bold in the current buffer.

These are recognized heuristically as text in the first column following two
newlines, and followed by indented text on the next line.

This function also handles the title lines of meta-manpages created with
troff's .so command, and extra backspaces that may have been inserted into the
final title line."
  (labels ((delete-extent-mapper (extent ignore) (delete-extent extent)))
    ;; 
    ;; Turn subsection header lines into bold. The first line is bolded
    ;; separately in `Manual-process-filter'.
    (goto-char (point-min))
    ;; Regexp to match section headers changed to match a non-indented
    ;; line preceded by a blank line and followed by an indented line.
    ;; This seems to work ok for manual pages but gives better results
    ;; with other nroff'd files
    ;;
    ;; Most systems have indented text the next line after a section
    ;; header, but some (Tru64) have an extra newline in between.
    (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n\n?[ \t]+[^ \t\n]" nil
                              t)
      (goto-char (match-end 1))
      ;; section headings are often highlighted by the man page
      ;; author, but other parts of the man page are highlighted the
      ;; same way, so make our lisp-deduced section header
      ;; highlighting higher priority.  This also avoids having
      ;; section headers being _random_ly highlighted alternately by
      ;; either man-heading or man-bold, which sure looks like a bug.
      ;; And for user interface issues, if it looks like a bug, it
      ;; _is_ a bug.
      (set-extent-properties (make-extent (match-beginning 1)
                                          (match-end 1))
                             '(face man-heading priority 1))
      (forward-line 1))
    (goto-char (point-min))
    ;; If this man page is a meta-manpage created with .so (cf. zshall(1)),
    ;; the individual sub-manpages have first-lines included that
    ;; Manual-mouseify-cross-references has made into cross-references. These
    ;; should really be treated as first lines and given the heading face.
    (while (re-search-forward "\n\n\n\n[A-Z0-9_.:]+([0-9][^)]*)[^\n]*\n\n\n\n"
                              nil t)
      (map-extents #'delete-extent-mapper nil (match-beginning 0) (match-end 0)
                   nil nil 'man)
      (set-extent-face (make-extent (+ (match-beginning 0) (length "\n\n\n\n"))
                                    (- (match-end 0) (length "\n\n\n\n")))
                       'man-heading))
    ;; Do the same thing for the very last line, which tends to get a
    ;; cross-reference extent when it shouldn't.
    (goto-char (point-max))
    (backward-char)
    (map-extents #'delete-extent-mapper nil (point-at-bol) (point-max) nil nil
                 'man)
    (set-extent-face (make-extent (point-at-bol) (point)) 'man-heading)
    ;; Some of the Perl module man pages have ridiculously long titles, which
    ;; groff chokes on for the title line, emitting backspaces with the
    ;; intention of rubbing out an already-printed character. Handle that.
    (beginning-of-line)
    (while (re-search-forward "[^\b]\b" (point-max) t)
      (delete-region (match-beginning 0) (match-end 0)))))

(defun Man-columns (frame)
  (let ((width (cond
                ((natnump Man-width)
                 Man-width)
                (Man-width (frame-width frame))
                (t (frame-width frame)))))
    (when (natnump Man-width-max)
      (setq width (min width Man-width-max)))
    width))

;;;###autoload
(defun manual-entry (topic)
  "Display the Unix manual entry for TOPIC.

If TOPIC starts with -k, then a system apropos search is performed
using man -k for TOPIC."
  (interactive
   (list (let ((default (save-excursion
                          (buffer-substring
                           (progn
                             (if (not (eobp))
                                 (forward-char))
                             (if (re-search-backward "\\sw\\|\\s_" nil t)
                                 (forward-char))
                             (re-search-backward
                              "\\(\\sw\\|\\s_\\)([0-9]+[A-Za-z]*\\="
                              (point-at-bol) t)
                             (skip-syntax-backward "w_")
                             (point))
                           (progn
                             (skip-syntax-forward "w_")
                             (re-search-forward "\\=([0-9]+[A-Za-z]*)" nil t)
                             (point))))))
           (read-string (if (equal default "")
                            "Manual entry: "
			  (concat "Manual entry (default " default "): "))
			nil 'Manual-page-minibuffer-history default))))
  (let (buffer section apropos-mode bufname)
    ;; Allow leading chapter numbers
    (if (string-match "\\([1-9n][a-zA-Z0-9]*\\) \\(.*\\)" topic)
	(setq topic (replace-match "\\2(\\1)" t nil topic)))
    (let ((case-fold-search nil))
      (if (and (null section)
               (string-match
                "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'"
                topic))
          (setq section (match-string 2 topic)
                topic (match-string 1 topic))
	  (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
	      (setq section "-k"
		    topic (substring topic (match-beginning 1))))))
    (when Manual-snip-subchapter
      ;; jwz: turn section "3x11" and "3n" into "3".
      (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section))
          (setq section (match-string 1 section))))

    (if (or (equal section "-k") (member "-k" Manual-switches))
        (setq apropos-mode t))
    (setq bufname (concat "Man" (when apropos-mode " apropos") ": " topic
                          (when section (concat "(" section ")"))))
    (if (setq buffer (get-buffer bufname))
        ;; Reselect an old man page buffer if it exists already.
	(Manual-mode-and-display-buffer buffer)
      (let ((args (append (if section (list section)) Manual-switches
                          (list topic)))
            (process-environment
             (list* "EMACS=t" "MAN_KEEP_FORMATTING=1"
                    "PAGER=cat" ;; apropos doesn't obery MANPAGER
                    process-environment))
            (page (if section (concat topic "(" section ")") topic))
            process)
        (when (or (console-on-window-system-p)
                  (not (or (getenv "MANWIDTH") (getenv "COLUMNS"))))
          (setq process-environment
                (cons (format "COLUMNS=%d" (Man-columns (selected-frame)))
                      process-environment)))
        (with-current-buffer (setq buffer (get-buffer-create bufname))
          (buffer-disable-undo buffer)
	  (defvar #424242=#:saved-window-configuration)
	  (set (make-local-variable '#424242#) (current-window-configuration)))
        (message "%s (running...)"
                 (mapconcat 'identity
                            (cons (file-name-nondirectory Manual-program)
                                  args) " "))
        (setf Manual-page-minibuffer-history
              (cons page (delete page Manual-page-minibuffer-history))
              process (apply #'start-process (concat "Manual (" topic ")")
			     (if (fboundp 'process-stderr-buffer)
				 (list buffer (generate-new-buffer
					       " *Manual-standard-error*"))
			       buffer)
                             Manual-program args)
              (process-filter process) 'Manual-process-filter
              (process-sentinel process)
              (lambda (process message)
                (let* ((buffer (process-buffer process)) saved-point
                       process-stderr-buffer process-command)
                  (labels
                      ((chomp-buffer-string (buffer)
                         (buffer-substring
                          (point-min buffer)
                          (if (eql (char-before (point-max buffer)) ?\n)
			      (1- (point-max buffer))
                            (point-max buffer))
                          buffer)))
                    (when (member (process-status process) '(signal exit))
		      (if (not (fboundp 'process-stderr-buffer))
			  ;; XEmacs 21.4, no way to tell stderr from stdout
			  (when (not (eql (process-exit-status process) 0))
			    (error (prog1
				       (chomp-buffer-string buffer)
				     (kill-buffer buffer))))
			(setq process-stderr-buffer
			      (process-stderr-buffer process))
			(if (eql (process-exit-status process) 0)
			    (if (> (buffer-size process-stderr-buffer) 0)
				(display-warning 'alert
				  (buffer-string process-stderr-buffer)))
			  (set-window-configuration
			   (symbol-value-in-buffer '#424242# buffer))
			  (error (prog1
				     (chomp-buffer-string
				      process-stderr-buffer)
				   (kill-buffer buffer)
				   (kill-buffer process-stderr-buffer))))
			(kill-buffer process-stderr-buffer))
                      (setq saved-point (point buffer))
		      ;; Flush any stashed data.
		      (Manual-process-filter process "" t)
                      (save-excursion
                        (setf process-command (process-command process)
                              (current-buffer) buffer
			      buffer-read-only nil
			      #424242# nil)
                        ;; This can't be done in the process filter because it
                        ;; depends on the number of lines of the complete
                        ;; output:
                        (Manual-nuke-nroff-bs-footers)
                        (or (member "-k" process-command)
                            ;; And this is tough to do in the filter because
                            ;; of the extra need to stash text that might
                            ;; overlap, when determining where the section
                            ;; titles are.
                            (Manual-boldface-section-titles))
                        ; (message "%s (done.)" args-string)
                        (setf buffer-read-only t)
			(set-buffer-modified-p nil buffer)
                        (goto-char saved-point)
                        (setf Manual-page-history
                              (cons (buffer-name)
                                    (delete (buffer-name)
                                            Manual-page-history)))))))))))
    buffer))

;;;###autoload
(define-key help-map "\C-m" 'manual-entry)

(defun Manual-mode ()
  "Major mode for viewing Unix manual entries. See `manual-entry'."
  (kill-all-local-variables)
  (setq buffer-read-only t)
  (use-local-map Manual-mode-map)
  (set (make-local-variable 'Manual-mode) t)
  (set-syntax-table Manual-mode-syntax-table)
  (setq major-mode 'Manual-mode
	mode-name "Manual")
  ;; man pages with long lines are buggy!
  ;; This looks slightly better if they only
  ;; overran by a couple of chars.
  (setq truncate-lines t)
  ;; turn off horizontal scrollbars in this buffer
  (when (featurep 'scrollbar)
    (set-specifier scrollbar-height (cons (current-buffer) 0)))
  (make-local-hook 'kill-buffer-hook)
  (add-hook 'kill-buffer-hook #'(lambda ()
				  (setq Manual-page-history
					(delete (buffer-name)
						Manual-page-history)))
	    nil t)
  (run-hooks 'Manual-mode-hook))

(defun Manual-mode-and-display-buffer (buffer)
  "Call `Manual-mode' in BUFFER, and then display it.

BUFFER is displayed as described in `Manual-buffer-view-mode'."
  (when (buffer-name buffer) ;; If we don't have a separate stderr, and
			     ;; man(3) has errored, BUFFER may have been
			     ;; killed. Don't choke on this.
    (save-excursion (set-buffer buffer) (Manual-mode))
    (funcall (case Manual-buffer-view-mode
                      ((t) 'view-buffer)
                      ((nil) (or temp-buffer-show-function 'display-buffer))
                      (otherwise 'view-buffer-other-window))
                    buffer)
    ;; view-minor-mode-map is a suppressed keymap; that is, usually
    ;; self-inserting characters are explicitly undefined, and this
    ;; un-definition overrides further keymaps that are searched when
    ;; processing a keystroke. This means that the Manual mode local map is
    ;; ignored for key-presses. Work around this by adding it to the
    ;; minor-mode-map-alist ahead of view-minor-mode-map.
    ;; view-minor-mode-map probably shouldn't be a suppressed keymap.
    (if (or (and (assq 'Manual-mode minor-mode-map-alist)
                 (assq 'view-minor-mode minor-mode-map-alist)
                 (< (position 'view-minor-mode minor-mode-map-alist :key #'car)
                    (position 'Manual-mode minor-mode-map-alist :key #'car)))
            (not (assq 'Manual-mode minor-mode-map-alist)))
        (setq minor-mode-map-alist
              (acons 'Manual-mode Manual-mode-map
                     (delete* 'Manual-mode minor-mode-map-alist :key #'car))))))

(defun Manual-last-page ()
  "Switch to the last manual entry buffer viewed."
  (interactive)
  (let ((list Manual-page-history))
    (while (or (not
                (get-buffer
                 (car
                  (or
                   list
                   (error
                    'invalid-argument
                    (substitute-command-keys
                     (format
                      "No %smanual page buffers found. Use \\[manual-entry]."
                      (if (eq 'Manual-mode major-mode) "other " ""))))))))
               (eq (get-buffer (car list)) (current-buffer)))
      (setq list (cdr list)))
    (setq Manual-page-history
          (cons (car list) (delete (car list) Manual-page-history)))
    (switch-to-buffer (car Manual-page-history))))

(defun Manual-nuke-nroff-bs-footers ()
  "Remove page footers from nroff output, for on-screen display.

Some implementations of man use nroff to produce `paginated' output with a
page size of 66 lines, of which several are devoted to the header and footer.
Each header and footer consists of 3 newlines, one informational line, and
either 3 additional newlines in the case of Solaris nroff, or 2 additional
newlines in the case of groff.

Of course, pagination is an incredibly stupid idea for online information
presentation instead of printing to real paper, and so some system vendors
have chosen to improve on traditional behavior by providing non-paginated
output. We conservatively autodetect whether the output is in fact paginated.
Misdetection is still possible, but highly unlikely.  For starters, the output
from man must accidentally be a multiple of 66 lines.

Note that if nroff spits out error messages, pages will be more than 66 lines
high, and we'll misdetect page starts.  That's ok because standard nroff
doesn't do any diagnostics, and the `gnroff' wrapper for groff turns off error
messages for compatibility.  (At least, it's supposed to.)"

  ;; Autodetect and nuke headers and footers in nroff output.
  (goto-char (point-min))

  ;; first lose the status output
  (let ((case-fold-search t))
    (if (and (not (looking-at "[^\n]*warning"))
	     (looking-at "Reformatting.*\n"))
	(delete-region (match-beginning 0) (match-end 0))))

  ;; kludge around a groff bug where it won't keep quiet about some
  ;; warnings even with -Wall or -Ww.
  (cond ((looking-at "grotty:")
	 (while (looking-at "grotty:")
	   (delete-region (point) (progn (forward-line 1) (point))))
	 (if (looking-at " *done\n")
	     (delete-region (point) (match-end 0)))))

  (block nuke-headers-and-footers
    (let* ((page-starts '())
	   (solaris-pagination		; 66 - 2 * (3 + 1 + 3) = 52
	    "\\(\n\n\n[^\n]+\n\n\n\n\\)\\([^\n]*\n\\)\\{52\\}\\(\n\n\n[^\n]+\n\n\n\n\\)")
	   (groff-pagination		; 66 - 2 * (3 + 1 + 2) = 54
	    "\\(\n\n\n[^\n]+\n\n\n\\)\\([^\n]*\n\\)\\{54\\}\\(\n\n\n[^\n]+\n\n\n\\)")
	   (pagination solaris-pagination))
      ;; First pass.
      ;; Collect the page start markers in reverse order.
      ;; It's easiest to delete backwards starting from the end of the buffer.
      ;; `page-starts' conveniently ends up in the desired reversed order.
      ;; Verify that each header and footer looks like "\n\n\n[^\n]+\n\n\n\n?".
      (while (not (eobp))
	(when (not (looking-at pagination))
	  (setq pagination groff-pagination)
	  (when (not (looking-at pagination))
	    (return-from nuke-headers-and-footers)))
	(push (point-marker) page-starts)
	(goto-char (match-end 0)))

      ;; Second pass.
      ;; Delete all the headers and footers, except for the first and last one,
      ;; since they do actually contain some useful information.
      (dolist (page-start page-starts)
	(goto-char page-start)
	(looking-at pagination)		; guaranteed to match, by first pass.

	;; Delete footers, except merely trim whitespace from the last one.
	(if (eql (match-end 0) (point-max))
	    (progn
	      ;; last footer
	      ;; Leave exactly two newlines before last footer.
	      (goto-char (match-beginning 3))
	      (skip-chars-backward "\n")
	      (forward-char 2)
	      (delete-region (point) (save-excursion
				       (skip-chars-forward "\n")
				       (point))))
	  (progn
	    ;; footer with adjoining header
	    (goto-char (match-beginning 3))
	    (delete-region (point) (match-end 3)) ; nuke footer
	    ;; Note: next page's header is already nuked, because
	    ;; we're processing the buffer backwards.
	    (save-match-data
	      (skip-chars-backward "\n")
	      (cond
	       ;; Compress multiple newlines where page breaks used to be.
	       ;; These happen if the man page has a "keep" that
	       ;; cannot spill over a page break, like a table.
	       ;; We simply compress multiple newlines to one.
	       ((looking-at "\n\n\n+")
		(delete-region (+ 2 (match-beginning 0)) (match-end 0)))
	       ;; There is no way to tell whether the page separator
	       ;; we've removed is a logical paragraph separator, so we
	       ;; guess with a simple heuristic that gets the newlines
	       ;; correct most of the time.  Section headers and option
	       ;; descriptions get a newline separator added.
	       ((looking-at "\n\\([^ \t\n]\\|[ \t]+-\\)")
		(insert ?\n))))))

	;; Delete headers, except merely trim whitespace from the first one.
	(if (eql page-start (point-min))
	    ;; Leave exactly two newlines between first header and body.
	    (delete-region (match-end 1)
			   (save-excursion (goto-char (match-end 1))
					   (skip-chars-backward "\n")
					   (+ 2 (point))))
	  ;; Completely nuke non-initial headers
	  (delete-region (match-beginning 1) (match-end 1)))

	(set-marker page-start nil))))	; block nuke-headers-and-footers

  ;; Delete newlines at beginning and end of buffer, whether or not
  ;; man is feeding us 66-line paginated output.
  ;; Tru64 is particularly generous with trailing newlines.
  ;;
  ;; Leave exactly one newline at end of buffer.
  (goto-char (point-max))
  (skip-chars-backward "\n")
  (if (eobp)
      (insert ?\n)
    (delete-region (1+ (point)) (point-max)))
  ;; Leave exactly zero newlines at beginning of buffer.
  (delete-region (point-min)
		 (save-excursion (goto-char (point-min))
				 (skip-chars-forward "\n")
				 (point))))

(defun Manual-mouseify-cross-references (begin end)
  "Make the manual cross-references between BEGIN and END clickable.

Clicking on a cross-reference of the form `ls(1)' calls `manual-entry' with an
appropriate TOPIC argument."
  (let ((case-fold-search nil) s e name extent re-search-forward
        found section-length)
    (goto-char begin)
    (while (progn
	     (while (and (not found)
			 (setq re-search-forward
			       (re-search-forward "([0-9]" end t)))
	       (goto-char (- (point) (length "(1")))
	       (if (eql (skip-chars-backward "-a-zA-Z0-9_.:") 0)
                   ;; Don't limit the above #'skip-chars-forward by BEGIN,
                   ;; there may be parts of the command name before that.
		   (goto-char re-search-forward)
		 (if (looking-at
		      ;; This function used to just #'re-search-forward for
		      ;; the following regexp. It takes about a third of the
		      ;; time to #'re-search-forward for the shorter
		      ;; expression, above, and then to back up.
                      ;;
                      ;; This is reduced further by only calling
                      ;; #'Manual-mouseify-cross-references if there is a
                      ;; close parenthesis in the string supplied to
		      ;; #'Manual-process-filter; see that latter function.
		      "[a-zA-Z_][-a-zA-Z0-9_.:]*\\(([0-9][a-zA-Z0-9]*)\\)")
		     (setq found t)
		   (goto-char re-search-forward))))
	     re-search-forward)
      (setq s (match-beginning 0)
	    e (match-end 0)
	    name (buffer-substring s e)
            section-length (- (match-end 1) (match-beginning 1))
	    found nil) ;; Let the loop above continue next time around.

      ;; If there could be upper case letters in the section, downcase them.
      (if (> section-length (length "(1)"))
	  (setq name (concat (substring name 0 (- section-length))
			     (downcase (substring name (- section-length))))))

      ;; If this is a hyphenated cross-reference, we're on the second line,
      ;; first char now. Deal with the part of the cross-reference on the
      ;; previous line.
      (when (progn
	      (beginning-of-line)
	      (and (member* (char-before (1- (point))) '(?- ?\255))
                   (looking-at (concat "^[ \t]+" (regexp-quote name)))))
        (setf extent
              ;; Make an extent just for the bit on the previous line. Either
              ;; order for FROM, TO for the args is fine.
              (make-extent 
               (progn (backward-char) (point))
               (progn (skip-chars-backward "-\255a-zA-Z0-9_.:") (point)))
              ;; Construct the concatenated name, including the bits on both
              ;; lines. Don't include the trailing ?- or ?\255 from this line.
              name (concat (buffer-substring (point) (1- (point-at-eol)))
                           name)
              ;; Now set the properties of this constructed extent.
              (extent-property extent 'man) `(Manual-follow-cross-reference
                                              ,name)
              (extent-property extent 'highlight) t
              (extent-property extent 'keymap) Manual-mode-cross-reference-map
              (extent-face extent) 'man-cross-reference))
      ;; Create an extent reflecting the original matched regexp, using the
      ;; NAME (possibly de-hyphenated). Create the appropriate interactive
      ;; properties.
      (setf extent (make-extent s e)
            (extent-property extent 'man) `(Manual-follow-cross-reference
                                            ,name)
            (extent-property extent 'highlight) t
            (extent-property extent 'keymap) Manual-mode-cross-reference-map
            (extent-face extent) 'man-cross-reference)
      (goto-char (min e (or re-search-forward 1))))))

(defun Manual-follow-cross-reference (&optional name-or-event)
  "Invoke `manual-entry' on the cross-reference under the mouse.

When invoked noninteractively, NAME-OR-EVENT may be a cross-reference string
to parse instead."
  (interactive
   (list (or current-mouse-event ;; also reflects current misc-user events
             (and (eql last-command-char ?\C-m)
                  (let* ((extent (extent-at (point) nil 'man))
                         (data (and extent (extent-property extent
                                                            'man))))
                    (and (eq 'Manual-follow-cross-reference (car-safe data))
                         (cadr data)))))))
  (if (eventp name-or-event)
      (let* ((p (event-point name-or-event))
	     (extent (and p (extent-at p
			     (event-buffer name-or-event)
			     'highlight)))
	     (data (and extent (extent-property extent 'man))))
	(if (eq (car-safe data) 'Manual-follow-cross-reference)
	    (apply 'Manual-follow-cross-reference (cdr data))
	  (error "No manual cross-reference there.")))
    (manual-entry name-or-event)))

(defun Manual-popup-menu (event)
  "Pop up a menu of cross-references in this manual page.

If there is a cross-reference under the mouse button which invoked this
command, it will be the first item on the menu.  Otherwise, they are
qon the menu in the order in which they appear in the buffer."
  (interactive "e")
  (let* ((buffer (event-buffer event))
         (p (event-point event))
         (extent (and p (extent-at p buffer 'highlight)))
         (data (and extent (extent-property extent 'man)))
         (cross-reference (and (eq (car-safe data)
                                   'Manual-follow-cross-reference) data))
         (sep "---")
         (items (if cross-reference (list cross-reference))))
    (map-extents #'(lambda (extent ignore)
		     (let ((data (extent-property extent 'man)))
		       (if (and (eq (car-safe data)
                                    'Manual-follow-cross-reference)
				(not (member data items)))
			   (setq items (cons data items)))
                       nil))
		 buffer nil nil nil nil 'man)
    (popup-menu
     (if items
         `("Manual Entry"
           ,@(if cross-reference
                 `([,(cadr cross-reference) ,cross-reference t] ,sep))
           ,@(menu-split-long-menu
              (loop for item in (delete* cross-reference items)
                    with result = nil
                    do (setq result 
                             (cons (if (eq item sep)
                                       item
                                     (vector (cadr item) item t))
                                   result))
                    finally return result)))
       '("Manual Entry" ["No cross-references in this buffer" nil nil])))))

;;;###autoload
(defun Manual-pager-cleanup-hook ()
  "If the current buffer is an unprocessed man page, process and format it.

The formatting done is that described in the `Manual-process-filter'
docstring, and corresponds to that done when invoking \\[manual-entry].  The
formatted output is in a new buffer, and any unmodified original buffer is
killed.

Intended for use as a `gnuserv-visit-hook' entry, so that when gnuclient(1) is
used as the shell's PAGER, man pages look readable within XEmacs."
  (let ((buffer-name (or buffer-file-name (buffer-name))) manpage)
    (goto-char (point-min))
    (when (and (looking-at
                "\\([a-zA-Z_][-a-zA-Z0-9_.:]*\\)([0-9][a-zA-Z0-9]*)")
               (setq manpage (downcase (match-string 1)))
               ;; There will be a backspace character within the first
               ;; kilobyte if this is an unprocessed man page:
               (search-forward "\b" (min 1024 (point-max)) t))
      (let* ((output (generate-new-buffer 
                      (concat "Man: " manpage " (formatted from `"
                              buffer-name "')")))
             ;; This is a dummy process, just created so Manual-process-filter
             ;; has a process to manipulate.
	     (process (open-network-stream (buffer-name output) output
                                           "localhost" 34271 'udp))
	     (position (point-min))
	     (buffer (current-buffer)) next-position)
	(set-marker (process-mark process) (point-min output))
	(while (< position (point-max buffer))
	  (setq next-position (min (+ position 4096) (point-max buffer)))
	  (Manual-process-filter process
				 (buffer-substring position
						   next-position
						   buffer)
				 (eql next-position (point-max buffer)))
          (when (< position 4096)
            ;; Redisplay, once we have something to show.
            (sit-for 0.0))
	  (setq position next-position)
	  (set-marker (process-mark process) (point-max output)))
	(delete-process process)
	(set-buffer (prog1 output
                      (unless (buffer-modified-p buffer)
                        (kill-buffer buffer))))
        (setq buffer-read-only nil)
        (goto-char (prog1 (point)
                     (Manual-nuke-nroff-bs-footers)
                     (Manual-boldface-section-titles)))
        (setq buffer-read-only t)
	(set-buffer-modified-p nil)))))

;;;###autoload
(add-hook 'gnuserv-visit-hook 'Manual-pager-cleanup-hook)

(provide 'man)

;;; man.el ends here
