home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / man.el < prev    next >
Encoding:
Text File  |  1995-08-28  |  43.1 KB  |  1,143 lines
  1. ;;; man.el --- browse UNIX manual pages
  2. ;; Keywords: help
  3.  
  4. ;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc.
  5. ;;
  6. ;; This file is part of XEmacs.
  7.  
  8. ;; XEmacs is free software; you can redistribute it and/or modify it
  9. ;; under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; XEmacs is distributed in the hope that it will be useful, but
  14. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. ;; General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  20. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;; Mostly rewritten by Alan K. Stebbens <aks@hub.ucsb.edu> 11-apr-90.
  23. ;;
  24. ;;  o  Match multiple man pages using TOPIC as a simple pattern
  25. ;;  o  Search unformatted pages, even when formatted matches are found
  26. ;;  o  Query the user as to which pages are desired
  27. ;;  o  Use of the prefix arg to toggle/bypass the above features
  28. ;;  o  Buffers named by the first topic in the buffer
  29. ;;  o  Automatic uncompress for compressed man pages (.Z, .z, and .gz)
  30. ;;  o  View the resulting buffer using M-x view mode
  31. ;;
  32. ;; Modified 16-mar-91 by Jamie Zawinski <jwz@lucid.com> to default the 
  33. ;; manual topic to the symbol at point, just like find-tag does.
  34. ;;
  35. ;; Modified 22-mar-93 by jwz to use multiple fonts and follow xrefs with mouse.
  36. ;;
  37. ;; Modified 16-apr-93 by Dave Gillespie <daveg@synaptics.com> to make
  38. ;; apropos work nicely; work correctly when bold or italic is unavailable; 
  39. ;; reuse old buffer if topic is re-selected (in Manual-topic-buffer mode).
  40. ;;
  41. ;; Modified 4-apr-94 by jwz: merged in Tibor Polgar's code for manpath.conf.
  42. ;;
  43. ;; Modified 19-apr-94 by Tibor Polgar <tlp00@spg.amdahl.com> to add support for
  44. ;; $PAGER variable to be emacsclient and properly process man pages (assuming
  45. ;; the man pages were built by man in /tmp.  also fixed bug with man list being
  46. ;; backwards.
  47. ;;
  48. ;; Modified 23-aug-94 by Tibor Polgar <tlp00@spg.amdahl.com> to add support for
  49. ;; displaying only one instance of a man page (Manual-unique-man-sections-only)
  50. ;; Fixed some more man page ordering bugs, bug with Manual-query-multiple-pages.
  51. ;;
  52. ;; Modified 29-nov-94 by Ben Wing <wing@spg.amdahl.com>: small fixes
  53. ;; that should hopefully make things work under HPUX and IRIX.; 
  54. ;;
  55. ;; Modified 15-jul-95 by Dale Atems <atems@physics.wayne.edu>:
  56. ;; some extensive rewriting to make things work right (more or less)
  57. ;; under IRIX.
  58. ;; 
  59. ;; This file defines "manual-entry", and the remaining definitions all
  60. ;; begin with "Manual-".  This makes the autocompletion on "M-x man" work.
  61. ;;
  62. ;; Variables of interest:
  63. ;;
  64. ;;    Manual-program
  65. ;;    Manual-topic-buffer
  66. ;;    Manual-buffer-view-mode
  67. ;;    Manual-directory-list
  68. ;;    Manual-formatted-directory-list
  69. ;;    Manual-match-topic-exactly
  70. ;;    Manual-query-multiple-pages
  71. ;;    Manual-page-history
  72. ;;    Manual-subdirectory-list
  73. ;;    Manual-man-page-section-ids
  74. ;;    Manual-formatted-page-prefix
  75. ;;    Manual-unformatted-page-prefix
  76. ;;    Manual-use-full-section-ids
  77.  
  78. (defvar Manual-program "man" "\
  79. *Name of the program to invoke in order to format the source man pages.")
  80.  
  81. (defvar Manual-section-switch (if (eq system-type 'usg-unix-v) "-s" nil)
  82.   "SysV needs this to work right.")
  83.  
  84. (defvar Manual-topic-buffer t "\
  85. *Non-nil means \\[Manual-entry] should output the manual entry for TOPIC into
  86. a buffer named *man TOPIC*, otherwise, it should name the buffer
  87. *Manual Entry*.")
  88.  
  89. (defvar Manual-buffer-view-mode t "\
  90. *Whether manual buffers should be placed in view-mode.
  91. nil means leave the buffer in fundamental-mode in another window.
  92. t means use `view-buffer' to display the man page in the current window.
  93. Any other value means use `view-buffer-other-window'.")
  94.  
  95. (defvar Manual-match-topic-exactly t "\
  96. *Non-nil means that \\[manual-entry] will match the given TOPIC exactly, rather
  97. apply it as a pattern.  When this is nil, and \"Manual-query-multiple-pages\"
  98. is non-nil, then \\[manual-entry] will query you for all matching TOPICs.
  99. This variable only has affect on the preformatted man pages (the \"cat\" files),
  100. since the \"man\" command always does exact topic matches.")
  101.  
  102. (defvar Manual-query-multiple-pages nil "\
  103. *Non-nil means that \\[manual-entry] will query the user about multiple man
  104. pages which match the given topic.  The query is done using the function 
  105. \"y-or-n-p\".  If this variable is nil, all man pages with topics matching the
  106. topic given to \\[manual-entry] will be inserted into the temporary buffer.
  107. See the variable \"Manual-match-topic-exactly\" to control the matching.")
  108.  
  109. (defvar Manual-unique-man-sections-only nil
  110.   "*Only present one man page per section.  This variable is useful if the same or
  111. up/down level man pages for the same entry are present in mulitple man paths.
  112. When set to t, only the first entry found in a section is displayed, the others
  113. are ignored without any messages or warnings.  Note that duplicates can occur if
  114. the system has both formatted and unformatted version of the same page.")
  115.  
  116. (defvar Manual-mode-hook nil
  117.   "Function or functions run on entry to Manual-mode.")
  118.  
  119. (defvar Manual-directory-list nil "\
  120. *A list of directories used with the \"man\" command, where each directory
  121. contains a set of \"man?\" and \"cat?\" subdirectories.  If this variable is nil,
  122. it is initialized by \\[Manual-directory-list-init].")
  123.  
  124. (defvar Manual-formatted-directory-list nil "\
  125. A list of directories containing formatted man pages.  Initialized by
  126. \\[Manual-directory-list-init].")
  127.  
  128. (defvar Manual-unformatted-directory-list nil "\
  129. A list of directories containing the unformatted (source) man pages.  
  130. Initialized by \\[Manual-directory-list-init].")
  131.  
  132. (defvar Manual-page-history nil "\
  133. A list of names of previously visited man page buffers.")
  134.  
  135. (defvar Manual-manpath-config-file "/usr/lib/manpath.config"
  136.   "*Location of the manpath.config file, if any.")
  137.  
  138. (defvar Manual-apropos-switch "-k"
  139.   "*Man apropos switch")
  140.  
  141. ;; New variables.
  142.  
  143. (defvar Manual-subdirectory-list nil "\
  144. A list of all the subdirectories in which man pages may be found.
  145. Iniialized by Manual-directory-list-init.")
  146.  
  147. ;; This is for SGI systems; don't know what it should be otherwise.
  148. (defvar Manual-man-page-section-ids "1nl6823457poD" "\
  149. String containing all suffix characters for \"cat\" and \"man\"
  150. that identify valid sections of the Un*x manual.") 
  151.  
  152. (defvar Manual-formatted-page-prefix "cat" "\
  153. Prefix for directories where formatted man pages are to be found.
  154. Defaults to \"cat\".")
  155.  
  156. (defvar Manual-unformatted-page-prefix "man" "\
  157. Prefix for directories where unformatted man pages are to be found.
  158. Defaults to \"man\".")
  159.  
  160. (defvar Manual-leaf-signature "" "\
  161. Regexp for identifying \"leaf\" subdirectories in the search path.
  162. If empty, initialized by Manual-directory-list-init.")
  163.  
  164. (defvar Manual-use-full-section-ids t "\
  165. If non-nil, pass full section ids to Manual-program, otherwise pass
  166. only the first character. Defaults to 't'.")
  167.  
  168. (defvar Manual-use-subdirectory-list (eq system-type 'irix) "\
  169. This makes manual-entry work correctly on SGI machines but it
  170. imposes a large startup cost which is why it is not simply on by
  171. default on all systems.")
  172.  
  173. (make-face 'man-italic)
  174. (or (face-differs-from-default-p 'man-italic)
  175.     (copy-face 'italic 'man-italic))
  176. ;; XEmacs (from Darrell Kindred): underlining is annoying due to
  177. ;; large blank spaces in this face.
  178. ;; (or (face-differs-from-default-p 'man-italic)
  179. ;;    (set-face-underline-p 'man-italic t))
  180.  
  181. (make-face 'man-bold)
  182. (or (face-differs-from-default-p 'man-bold)
  183.     (copy-face 'bold 'man-bold))
  184. (or (face-differs-from-default-p 'man-bold)
  185.     (copy-face 'man-italic 'man-bold))
  186.  
  187. (make-face 'man-heading)
  188. (or (face-differs-from-default-p 'man-heading)
  189.     (copy-face 'man-bold 'man-heading))
  190.  
  191. (make-face 'man-xref)
  192. (or (face-differs-from-default-p 'man-xref)
  193.     (set-face-underline-p 'man-xref t))
  194.  
  195. ;; Manual-directory-list-init
  196. ;; Initialize the directory lists.
  197.  
  198. (defun Manual-directory-list-init (&optional arg) 
  199.   "Initialize the Manual-directory-list variable from $MANPATH
  200. if it is not already set, or if a prefix argument is provided."
  201.   (interactive "P")
  202.   (if arg (setq Manual-directory-list nil))
  203.   (if (null Manual-directory-list)
  204.       (let ((manpath (getenv "MANPATH"))
  205.         (global (Manual-manpath-config-contents))
  206.         (dirlist nil)
  207.         dir)
  208.     (cond ((and manpath global)
  209.            (setq manpath (concat manpath ":" global)))
  210.           (global
  211.            (setq manpath global))
  212.           ((not manpath)
  213.            ;; XEmacs - (bpw/stig) Unix-specifix hack for lusers w/ no manpath
  214.            (setq manpath "/usr/local/man:/usr/share/man:/usr/contrib/man:/usr/X11/man:/usr/man:/usr/catman")))
  215.     ;; Make sure that any changes we've made internally are seen by man.
  216.     (setenv "MANPATH" manpath)
  217.     (while (string-match "\\`:*\\([^:]+\\)" manpath)
  218.       (setq dir (substring manpath (match-beginning 1) (match-end 1)))
  219.       (and (not (member dir dirlist))
  220.            (setq dirlist (cons dir dirlist)))
  221.       (setq manpath (substring manpath (match-end 0))))
  222.     (setq dirlist (nreverse dirlist))
  223.     (setq Manual-directory-list dirlist)
  224.     (setq Manual-subdirectory-list nil)
  225.     (setq Manual-formatted-directory-list nil)
  226.     (setq Manual-unformatted-directory-list nil)))
  227.   (if (string-equal Manual-leaf-signature "")
  228.       (setq Manual-leaf-signature
  229.         (concat "/\\("
  230.             Manual-formatted-page-prefix
  231.             "\\|" Manual-unformatted-page-prefix
  232.             "\\)"
  233.             "[" Manual-man-page-section-ids
  234.             "].?/.")))
  235.   (if Manual-use-subdirectory-list
  236.       (progn
  237.     (if (null Manual-subdirectory-list)
  238.         (setq Manual-subdirectory-list
  239.           (Manual-all-subdirectories Manual-directory-list
  240.                          Manual-leaf-signature nil)))
  241.     (if (null Manual-formatted-directory-list)
  242.         (setq Manual-formatted-directory-list
  243.           (Manual-filter-subdirectories Manual-subdirectory-list
  244.                         Manual-formatted-page-prefix)))
  245.     (if (null Manual-unformatted-directory-list)
  246.         (setq Manual-unformatted-directory-list
  247.           (Manual-filter-subdirectories Manual-subdirectory-list
  248.                         Manual-unformatted-page-prefix))))
  249.     (if (null Manual-formatted-directory-list)
  250.         (setq Manual-formatted-directory-list
  251.           (Manual-select-subdirectories Manual-directory-list
  252.                         Manual-formatted-page-prefix)))
  253.     (if (null Manual-unformatted-directory-list)
  254.         (setq Manual-unformatted-directory-list
  255.           (Manual-select-subdirectories Manual-directory-list
  256.                         Manual-unformatted-page-prefix)))))
  257.  
  258.  
  259. (defun Manual-manpath-config-contents ()
  260.   "Parse the `Manual-manpath-config-file' file, if any.
  261. Returns a string like in $MANPATH."
  262.   (if (and Manual-manpath-config-file
  263.        (file-readable-p Manual-manpath-config-file))
  264.       (let ((buf (get-buffer-create " *Manual-config*"))
  265.         path)
  266.     (set-buffer buf)
  267.     (buffer-disable-undo buf)
  268.     (erase-buffer)
  269.     (insert-file-contents Manual-manpath-config-file)
  270.     (while (re-search-forward "^\\(MANDATORY_MANPATH\\|MANPATH_MAP\\)"
  271.                   nil t)
  272.       (and (re-search-forward "\\(/[^ \t\n]+\\)[ \t]*$")
  273.            (setq path (concat path (buffer-substring (match-beginning 1)
  274.                              (match-end 1))
  275.                   ":"))))
  276.     (kill-buffer buf)
  277.     path)))
  278. ;;
  279. ;; manual-entry  -- The "main" user function
  280. ;;
  281.  
  282. ;;;###autoload
  283. (defun manual-entry (topic &optional arg silent)
  284.   "Display the Unix manual entry (or entries) for TOPIC.
  285. If prefix arg is given, modify the search according to the value:
  286.   2 = complement default exact matching of the TOPIC name;
  287.       exact matching default is specified by `Manual-match-topic-exactly'
  288.   3 = force a search of the unformatted man directories
  289.   4 = both 2 and 3
  290. The manual entries are searched according to the variable
  291. Manual-directory-list, which should be a list of directories.  If
  292. Manual-directory-list is nil, \\[Manual-directory-list-init] is
  293. invoked to create this list from the MANPATH environment variable.
  294. See the variable Manual-topic-buffer which controls how the buffer
  295. is named.  See also the variables Manual-match-topic-exactly,
  296. Manual-query-multiple-pages, and Manual-buffer-view-mode."
  297.   (interactive
  298.    (list (let* ((fmh "-A-Za-z0-9_.")
  299.         (default (save-excursion
  300.                (buffer-substring
  301.                 (progn
  302.                   (re-search-backward "\\sw" nil t)
  303.                   (skip-chars-backward fmh) (point))
  304.                 (progn (skip-chars-forward fmh) (point)))))
  305.         (thing (read-string
  306.             (if (equal default "") "Manual entry: "
  307.               (concat "Manual entry: (default " default ") ")))))
  308.        (if (equal thing "") default thing))
  309.      (prefix-numeric-value current-prefix-arg)))
  310.   ;;(interactive "sManual entry (topic): \np")
  311.   (or arg (setq arg 1))
  312.   (Manual-directory-list-init nil)
  313.   (let ((exact (if (or (= arg 2) (= arg 4))
  314.            (not Manual-match-topic-exactly)
  315.          Manual-match-topic-exactly))
  316.     (force (if (>= arg 3)
  317.                    t
  318.                    nil))
  319.     section fmtlist manlist apropos-mode)
  320.     (let ((case-fold-search nil))
  321.       (if (and (null section)
  322.            (string-match
  323.         "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
  324.       (setq section (substring topic (match-beginning 2)
  325.                    (match-end 2))
  326.         topic (substring topic (match-beginning 1)
  327.                  (match-end 1)))
  328.     (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
  329.         (setq section "-k"
  330.           topic (substring topic (match-beginning 1))))))
  331.     (if (equal section "-k")
  332.     (setq apropos-mode t)
  333.       (or silent
  334.       (message "Looking for formatted entry for %s%s..."
  335.            topic (if section (concat "(" section ")") "")))
  336.       (setq fmtlist (Manual-select-man-pages
  337.                       Manual-formatted-directory-list
  338.                       topic section exact '()))
  339.       (if (or force (not section) (null fmtlist))
  340.       (progn
  341.         (or silent
  342.         (message "%sooking for unformatted entry for %s%s..."
  343.              (if fmtlist "L" "No formatted entry, l")
  344.              topic (if section (concat "(" section ")") "")))
  345.         (setq manlist (Manual-select-man-pages
  346.                             Manual-unformatted-directory-list
  347.                             topic section exact (if force '() fmtlist))))))
  348.  
  349.     ;; Delete duplicate man pages (a file of the same name in multiple
  350.     ;; directories.)
  351.     (or nil ;force
  352.         (let ((rest (append fmtlist manlist)))
  353.           (while rest
  354.             (let ((rest2 (cdr rest)))
  355.               (while rest2
  356.                 (if (equal (file-name-nondirectory (car rest))
  357.                            (file-name-nondirectory (car rest2)))
  358.                     (setq fmtlist (delq (car rest2) fmtlist)
  359.                           manlist (delq (car rest2) manlist)))
  360.                 (setq rest2 (cdr rest2))))
  361.             (setq rest (cdr rest)))))
  362.  
  363.     (if (not (or fmtlist manlist apropos-mode))
  364.         (progn
  365.           (message "No entries found for %s%s" topic
  366.                    (if section (concat "(" section ")") ""))
  367.           nil)
  368.       (let ((bufname (cond ((not Manual-topic-buffer)
  369.                             ;; What's the point of retaining this?
  370.                             (if apropos-mode
  371.                                 "*Manual Apropos*"
  372.                                 "*Manual Entry*"))
  373.                            (apropos-mode
  374.                             (concat "*man apropos " topic "*"))
  375.                            (t
  376.                             (concat "*man "
  377.                                     (cond (exact
  378.                                            (if section
  379.                                                (concat topic "." section)
  380.                                                topic))
  381.                                           ((or (cdr fmtlist) (cdr manlist)
  382.                                                (and fmtlist manlist))
  383.                                            ;; more than one entry found
  384.                                            (concat topic "..."))
  385.                                           (t
  386.                                            (file-name-nondirectory
  387.                                             (car (or fmtlist manlist)))))
  388.                                     "*"))))
  389.             (temp-buffer-show-function 
  390.              (cond ((eq 't Manual-buffer-view-mode) 'view-buffer)
  391.                    ((eq 'nil Manual-buffer-view-mode)
  392.                     temp-buffer-show-function)
  393.                    (t 'view-buffer-other-window))))
  394.  
  395.         (if apropos-mode
  396.             (setq manlist (list (format "%s.%s" topic section))))
  397.  
  398.         (cond
  399.           ((and Manual-topic-buffer (get-buffer bufname))
  400.            ;; reselect an old man page buffer if it exists already.
  401.            (save-excursion
  402.              (set-buffer (get-buffer bufname))
  403.              (Manual-mode))
  404.            (if temp-buffer-show-function
  405.                (funcall temp-buffer-show-function (get-buffer bufname))
  406.                (display-buffer bufname)))
  407.           (t
  408.            (with-output-to-temp-buffer bufname
  409.              (buffer-disable-undo standard-output)
  410.              (save-excursion
  411.                (set-buffer standard-output)
  412.                (setq buffer-read-only nil)
  413.                (erase-buffer)
  414.            (Manual-insert-pages fmtlist manlist apropos-mode)
  415.                (set-buffer-modified-p nil)
  416.                (Manual-mode)
  417.                ))))
  418.         (setq Manual-page-history
  419.               (cons (buffer-name)
  420.                     (delete (buffer-name) Manual-page-history)))
  421.         (message nil)
  422.         t))))
  423.  
  424. (defun Manpage-apropos (topic &optional arg silent)
  425.   "Apropos on Unix manual pages for TOPIC.
  426. It calls the function `manual-entry'. Look at this function for
  427. further description. Look also at the variable `Manual-apropos-switch',
  428. if this function doesn't work on your system."
  429.   (interactive
  430.    (list (let* ((fmh "-A-Za-z0-9_.")
  431.         (default (save-excursion
  432.                (buffer-substring
  433.                 (progn
  434.                   (re-search-backward "\\sw" nil t)
  435.                   (skip-chars-backward fmh) (point))
  436.                 (progn (skip-chars-forward fmh) (point)))))
  437.         (thing (read-string
  438.             (if (equal default "") "Manual entry: "
  439.               (concat "Manual entry: (default " default ") ")))))
  440.        (if (equal thing "") default thing))
  441.      (prefix-numeric-value current-prefix-arg)))
  442.   (manual-entry (concat Manual-apropos-switch " " topic) arg silent))
  443.  
  444. (defun Manual-insert-pages (fmtlist manlist apropos-mode)
  445.   (let ((sep (make-string 65 ?-))
  446.     name start end topic section)
  447.     (while fmtlist            ; insert any formatted files
  448.       (setq name (car fmtlist))
  449.       (goto-char (point-max))
  450.       (setq start (point))
  451.       ;; In case the file can't be read or uncompressed or
  452.       ;; something like that.
  453.       (condition-case ()
  454.       (Manual-insert-man-file name)
  455.     (file-error nil))
  456.       (goto-char (point-max))
  457.       (setq end (point))
  458.       (save-excursion
  459.     (save-restriction
  460.       (message "Cleaning manual entry for %s..."
  461.            (file-name-nondirectory name))
  462.       (narrow-to-region start end)
  463.       (Manual-nuke-nroff-bs)
  464.       (goto-char (point-min))
  465.       (insert "File: " name "\n")
  466.       (goto-char (point-max))
  467.       ))
  468.       (if (or (cdr fmtlist) manlist)
  469.       (insert "\n\n" sep "\n"))
  470.       (setq fmtlist (cdr fmtlist)))
  471.  
  472.     (while manlist            ; process any unformatted files
  473.       (setq name (car manlist))
  474.       (or (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\(\\.gz\\'\\)" name)
  475.       (string-match "\\([^/]+\\)\\.\\([^./]+\\)\\'" name))
  476.       (setq topic (substring name (match-beginning 1) (match-end 1)))
  477.       (setq section (substring name (match-beginning 2) (match-end 2)))
  478.       ;; This won't work under IRIX, because SGI man accepts only the
  479.       ;; "main" (one-character) section id, not full section ids
  480.       ;; like 1M, 3X, etc. Put (setq Manual-use-full-section-ids nil)
  481.       ;; in your .emacs to work around this problem.
  482.       (if (not (or Manual-use-full-section-ids (string-equal section "")))
  483.       (setq section (substring section 0 1)))
  484.       (message "Invoking man %s%s %s..."
  485.            (if Manual-section-switch
  486.            (concat Manual-section-switch " ")
  487.          "")
  488.            section topic)
  489.       (setq start (point))
  490.       (Manual-run-formatter name topic section)
  491.       (setq end (point))
  492.       (save-excursion
  493.     (save-restriction
  494.       (message "Cleaning manual entry for %s(%s)..." topic section)
  495.       (narrow-to-region start end)
  496.       (Manual-nuke-nroff-bs apropos-mode)
  497.       (goto-char (point-min))
  498.       (insert "File: " name "\n")
  499.       (goto-char (point-max))
  500.       ))
  501.       (if (cdr manlist)
  502.       (insert "\n\n" sep "\n"))
  503.       (setq manlist (cdr manlist))))
  504.   (if (< (buffer-size) 200)
  505.       (progn
  506.     (goto-char (point-min))
  507.     (if (looking-at "^File: ")
  508.         (forward-line 1))
  509.     (error (buffer-substring (point) (progn (end-of-line) (point))))))
  510.   nil)
  511.  
  512.  
  513. (defun Manual-run-formatter (name topic section)
  514.   (cond ((string-match "roff\\'" Manual-program)
  515.      ;; kludge kludge
  516.      (call-process Manual-program nil t nil "-Tman" "-man" name))
  517.     (Manual-section-switch
  518.      (call-process Manual-program nil t nil Manual-section-switch
  519.                section topic))
  520.     (t
  521.      (call-process Manual-program nil t nil section topic))))
  522.  
  523.  
  524. (defvar Manual-mode-map
  525.   (let ((m (make-sparse-keymap)))
  526.     (set-keymap-name m 'Manual-mode-map)
  527.     (define-key m "l" 'Manual-last-page)
  528.     (define-key m 'button2 'Manual-follow-xref)
  529.     (define-key m 'button3 'Manual-popup-menu)
  530.     m))
  531.  
  532. (defun Manual-mode ()
  533.   (kill-all-local-variables)
  534.   (setq buffer-read-only t)
  535.   (use-local-map Manual-mode-map)
  536.   (setq major-mode 'Manual-mode
  537.     mode-name "Manual")
  538.   ;; man pages with long lines are buggy!
  539.   ;; This looks slightly better if they only
  540.   ;; overran by a couple of chars.
  541.   (setq truncate-lines t)
  542.   ;; turn off horizontal scrollbars in this buffer
  543.   (set-specifier scrollbar-height (cons (current-buffer) 0))
  544.   (run-hooks 'Manual-mode-hook))
  545.  
  546. (defun Manual-last-page ()
  547.   (interactive)
  548.   (while (or (not (get-buffer (car (or Manual-page-history
  549.                        (error "No more history.")))))
  550.          (eq (get-buffer (car Manual-page-history)) (current-buffer)))
  551.     (setq Manual-page-history (cdr Manual-page-history)))
  552.   (switch-to-buffer (car Manual-page-history)))
  553.  
  554.  
  555. ;; Manual-select-subdirectories
  556. ;; Given a DIRLIST and a SUBDIR name, return all subdirectories of the former which
  557. ;; match the latter.
  558.  
  559. (defun Manual-select-subdirectories (dirlist subdir)
  560.   (let ((dirs '())
  561.         (case-fold-search nil)
  562.         (match (concat "\\`" (regexp-quote subdir)))
  563.         d)
  564.     (while dirlist
  565.       (setq d (car dirlist) dirlist (cdr dirlist))
  566.       (if (file-directory-p d)
  567.           (let ((files (directory-files d t match nil 'dirs-only))
  568.         (dir-temp '()))
  569.             (while files
  570.               (if (file-executable-p (car files))
  571.                   (setq dir-temp (cons (file-name-as-directory (car files))
  572.                                    dir-temp)))
  573.               (setq files (cdr files)))
  574.         (and dir-temp
  575.          (setq dirs (append dirs (nreverse dir-temp)))))))
  576.     dirs))
  577.  
  578.  
  579. ;; Manual-filter-subdirectories
  580. ;; Given a DIRLIST and a SUBDIR name, return all members of the former
  581. ;; which match the latter.
  582.  
  583. (defun Manual-filter-subdirectories (dirlist subdir)
  584.   (let ((match (concat
  585.         "/"
  586.         (regexp-quote subdir)
  587.         "[" Manual-man-page-section-ids "]"))
  588.     slist dir)
  589.     (while dirlist
  590.       (setq dir (car dirlist) dirlist (cdr dirlist))
  591.       (if (and (file-executable-p dir) (string-match match dir))
  592.         (setq slist (cons dir slist))))
  593.     (nreverse slist)))
  594.  
  595.  
  596. (defun Manual-all-subdirectories (dirlist leaf-signature dirs &optional silent) "\
  597. Given a DIRLIST, return a backward-sorted list of all subdirectories
  598. thereof, prepended to DIRS if non-nil. This function calls itself
  599. recursively until subdirectories matching LEAF-SIGNATURE are reached,
  600. or the hierarchy has been thoroughly searched. This code is a modified
  601. version of a function written by Tim Bradshaw (tfb@ed.ac.uk)."
  602.   (Manual-all-subdirectories-noloop dirlist leaf-signature dirs nil silent))
  603.  
  604. (defun Manual-all-subdirectories-noloop (dirlist leaf-signature dirs been &optional silent) "\
  605. Does the job of manual-all-subdirectories and keeps track of where it
  606. has been to avoid loops."
  607.   (let (dir)
  608.     (while dirlist
  609.       (setq dir (car dirlist) dirlist (cdr dirlist))
  610.       (if (file-directory-p dir)
  611.       (let ((dir-temp (cons (file-name-as-directory dir) dirs)))
  612.         ;; Without feedback the user might wonder about the delay!
  613.         (or silent (message
  614.             "Building list of search directories... %s"
  615.             (car dir-temp)))
  616.         (if (member (file-truename dir) been)
  617.         ()         ; Ignore. We have been here before
  618.           (setq been (cons (file-truename dir) been))
  619.           (setq dirs
  620.             (if (string-match leaf-signature dir)
  621.             dir-temp
  622.               (Manual-all-subdirectories-noloop
  623.                (directory-files dir t "[^.]$" nil 'dirs-only)
  624.                leaf-signature dir-temp been silent))))))))
  625.   dirs)
  626.  
  627.  
  628. (defvar Manual-bogus-file-pattern "\\.\\(lpr\\|ps\\|PS\\)\\'"
  629.   "Some systems have files in the man/man*/ directories which aren't man pages.
  630. This pattern is used to prune those files.")
  631.  
  632. ;; Manual-select-man-pages
  633. ;;
  634. ;; Given a DIRLIST, discover all filenames which complete given the TOPIC
  635. ;; and SECTION.
  636.  
  637. ;; ## Note: BSD man looks for .../man1/foo.1 and .../man1/$MACHINE/foo.1
  638.  
  639. ;; ## Fixed for SGI IRIX 5.x on Sat Jul 15 1995 by Dale Atems
  640. ;; (atems@physics.wayne.edu).
  641.  
  642. (defun Manual-select-man-pages (dirlist topic section exact shadow)
  643.   (let ((case-fold-search nil))
  644.     (and section
  645.       (let ((l '())
  646.         ;;(match (concat (substring section 0 1) "/?\\'"))
  647.         ;;                                          ^^^
  648.         ;; We'll lose any pages inside subdirectories of the "standard"
  649.         ;; ones if we insist on this! The following regexp should
  650.         ;; match any directory ending with the full section id or
  651.         ;; its first character, or any direct subdirectory thereof:
  652.         (match (concat "\\("
  653.                (regexp-quote section)
  654.                "\\|"
  655.                (substring section 0 1)
  656.                "\\)/?"))
  657.         d)
  658.     (while dirlist
  659.       (setq d (car dirlist) dirlist (cdr dirlist))
  660.       (if (string-match match d)
  661.           (setq l (cons d l))))
  662.     (setq dirlist l)))
  663.     (if shadow
  664.         (setq shadow (concat "/\\("
  665.                              (mapconcat #'(lambda (n)
  666.                                             (regexp-quote
  667.                                              (file-name-nondirectory n)))
  668.                                         shadow
  669.                                         "\\|")
  670.                              "\\)\\'")))
  671.     (let ((manlist '())
  672.           (match (concat "\\`"
  673.                            (regexp-quote topic)
  674.                 ;; **Note: on IRIX the preformatted pages
  675.                 ;; are packed, so they end with ".z". This
  676.                 ;; way you miss them if you specify a
  677.                 ;; section. I don't see any point to it here
  678.                 ;; even on BSD systems since we're looking
  679.                 ;; one level down already, but I can't test
  680.                 ;; this. More thought needed (???)
  681.  
  682.                (cond ((and section
  683.                        (not Manual-use-subdirectory-list))
  684.                   (concat "\\." (regexp-quote section)))
  685.                                  (exact
  686.                                   ;; If Manual-match-topic-exactly is
  687.                                   ;; set, then we must make sure the
  688.                                   ;; completions are exact, except for
  689.                                   ;; trailing weird characters after
  690.                                   ;; the section.
  691.                                   "\\.")
  692.                                  (t
  693.                                   ""))))
  694.           dir)
  695.       (while dirlist
  696.         (setq dir (car dirlist) dirlist (cdr dirlist))
  697.         (if (not (file-directory-p dir))
  698.             (progn
  699.               (message "warning: %s is not a directory" dir)
  700.               ;;(sit-for 1)
  701.               )
  702.             (let ((files (directory-files dir t match nil t))
  703.                   f)
  704.               (while files
  705.                 (setq f (car files) files (cdr files))
  706.                 (cond ((string-match Manual-bogus-file-pattern f)
  707.                ;(message "Bogus fule %s" f) (sit-for 2)
  708.                        )
  709.               ((and shadow (string-match shadow f))
  710.                        ;(message "Shadowed %s" f) (sit-for 2)
  711.                        )
  712.                       ((not (file-readable-p f))
  713.                        ;(message "Losing with %s" f) (sit-for 2)
  714.                        )
  715.                       (t
  716.                        (setq manlist (cons f manlist))))))))
  717.       (setq manlist (nreverse manlist))
  718.       (and Manual-unique-man-sections-only
  719.        (setq manlist (Manual-clean-to-unique-pages-only manlist)))
  720.       (if (and manlist Manual-query-multiple-pages)
  721.           (apply #'append
  722.                  (mapcar #'(lambda (page)
  723.                              (and page 
  724.                                   (y-or-n-p (format "Read %s? " page))
  725.                   (list page)))
  726.                          manlist))
  727.           manlist))))
  728.  
  729. (defun Manual-clean-to-unique-pages-only (manlist)
  730.   "Prune the current list of pages down to a unique set."
  731.   (let (page-name unique-pages)
  732.     (apply 'append
  733.        (mapcar '(lambda (page)
  734.               (cond (page
  735.                  (and (string-match ".*/\\(.*\\)" page)
  736.                   (setq page-name (substring page (match-beginning 1)
  737.                                  (match-end 1)))
  738.                   ;; try to clip off .Z, .gz suffixes
  739.                   (and (string-match "\\(.*\\)\\.\\(.+\\)\\.\\(.+\\)"
  740.                              page-name)
  741.                        (setq page-name
  742.                          (substring page-name (match-beginning 1)
  743.                             (match-end 2)))))
  744.                  ;; add Manual-unique-pages if it isn't there
  745.                  ;;  and return file
  746.                  (if (and unique-pages
  747.                       page-name
  748.                       (string-match (concat "\\b" page-name "\\b")
  749.                             unique-pages))
  750.                  nil
  751.                    (setq unique-pages (concat unique-pages
  752.                                  page-name
  753.                                  " "))
  754.                    (list page)))))
  755.            manlist))))
  756.                 
  757.  
  758.  
  759. (defun Manual-insert-man-file (name)
  760.   ;; Insert manual file (unpacked as necessary) into buffer
  761.   (cond ((equal (substring name -3) ".gz")
  762.      (call-process "gunzip" nil t nil "--stdout" name))
  763.         ((or (equal (substring name -2) ".Z")
  764.          ;; HPUX uses directory names that end in .Z and compressed
  765.          ;; files that don't.  How gratuitously random.
  766.              (let ((case-fold-search nil))
  767.                (string-match "\\.Z/" name)))
  768.      (call-process "zcat" name t nil)) ;; XEmacs change for HPUX
  769.     ((equal (substring name -2) ".z")
  770.      (call-process "pcat" nil t nil name))
  771.     (t
  772.      (insert-file-contents name))))
  773.  
  774. (defmacro Manual-delete-char (n)
  775.   ;; in v19, delete-char is compiled as a function call, but delete-region
  776.   ;; is byte-coded, so it's much faster.  (We were spending 40% of our time
  777.   ;; in delete-char alone.)
  778.   (list 'delete-region '(point) (list '+ '(point) n)))
  779.  
  780. ;; Hint: BS stands form more things than "back space"
  781. (defun Manual-nuke-nroff-bs (&optional apropos-mode)
  782.   (interactive "*")
  783.   ;;
  784.   ;; turn underlining into italics
  785.   ;;
  786.   (goto-char (point-min))
  787.   (while (search-forward "_\b" nil t)
  788.     ;; searching for underscore-backspace and then comparing the following
  789.     ;; chars until the sequence ends turns out to be much faster than searching
  790.     ;; for a regexp which matches the whole sequence.
  791.     (let ((s (match-beginning 0)))
  792.       (goto-char s)
  793.       (while (and (= (following-char) ?_)
  794.           (= (char-after (1+ (point))) ?\b))
  795.     (Manual-delete-char 2)
  796.     (forward-char 1))
  797.       (set-extent-face (make-extent s (point)) 'man-italic)))
  798.   ;;
  799.   ;; turn overstriking into bold
  800.   ;;
  801.   (goto-char (point-min))
  802.   (while (re-search-forward "\\([^\n]\\)\\(\b\\1\\)" nil t)
  803.     ;; Surprisingly, searching for the above regexp is faster than searching
  804.     ;; for a backspace and then comparing the preceding and following chars,
  805.     ;; I presume because there are many false matches, meaning more funcalls
  806.     ;; to re-search-forward.
  807.     (let ((s (match-beginning 0)))
  808.       (goto-char s)
  809.       ;; Some systems (SGI) overstrike multiple times, eg, "M\bM\bM\bM".
  810.       (while (looking-at "\\([^\n]\\)\\(\b\\1\\)+")
  811.     (delete-region (+ (point) 1) (match-end 0))
  812.     (forward-char 1))
  813.       (set-extent-face (make-extent s (point)) 'man-bold)))
  814.   ;;
  815.   ;; hack bullets: o^H+ --> +
  816.   (goto-char (point-min))
  817.   (while (search-forward "\b" nil t)
  818.     (Manual-delete-char -2))
  819.  
  820.   (if (> (buffer-size) 100) ; minor kludge
  821.       (Manual-nuke-nroff-bs-footers))
  822.   ;;
  823.   ;; turn subsection header lines into bold
  824.   ;;
  825.   (goto-char (point-min))
  826.   (if apropos-mode
  827.       (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t)
  828.     (forward-char -2)
  829.     (delete-backward-char 1))
  830.  
  831.     ;;    (while (re-search-forward "^[^ \t\n]" nil t)
  832.     ;;      (set-extent-face (make-extent (match-beginning 0)
  833.     ;;                                   (progn (end-of-line) (point)))
  834.     ;;                      'man-heading))
  835.  
  836.     ;; boldface the first line
  837.     (if (looking-at "[^ \t\n].*$")
  838.     (set-extent-face (make-extent (match-beginning 0) (match-end 0))
  839.              'man-bold))
  840.  
  841.     ;; boldface subsequent title lines
  842.     ;; Regexp to match section headers changed to match a non-indented
  843.     ;; line preceded by a blank line and followed by an indented line. 
  844.     ;; This seems to work ok for manual pages but gives better results
  845.     ;; with other nroff'd files
  846.     (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n[ \t]+[^ \t\n]" nil t)
  847.       (goto-char (match-end 1))
  848.       (set-extent-face (make-extent (match-beginning 1) (match-end 1))
  849.                'man-heading)
  850.       (forward-line 1))
  851.     )
  852.  
  853.   ;; Zap ESC7,  ESC8, and ESC9
  854.   ;; This is for Sun man pages like "man 1 csh"
  855.   (goto-char (point-min))
  856.   (while (re-search-forward "\e[789]" nil t)
  857.     (replace-match ""))
  858.   
  859.   ;; Nuke blanks lines at start.
  860.   ;;  (goto-char (point-min))
  861.   ;;  (skip-chars-forward "\n")
  862.   ;;  (delete-region (point-min) (point))
  863.  
  864.   (Manual-mouseify-xrefs)
  865.   )
  866.  
  867. (fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
  868.  
  869.  
  870. (defun Manual-nuke-nroff-bs-footers ()
  871.   ;; Nuke headers and footers.
  872.   ;;
  873.   ;; nroff assumes pages are 66 lines high.  We assume that, and that the
  874.   ;; first and last line on each page is expendible.  There is no way to
  875.   ;; tell the difference between a page break in the middle of a paragraph
  876.   ;; and a page break between paragraphs (the amount of extra whitespace
  877.   ;; that nroff inserts is the same in both cases) so this might strip out
  878.   ;; a blank line were one should remain.  I think that's better than
  879.   ;; leaving in a blank line where there shouldn't be one.  (Need I say
  880.   ;; it: FMH.)
  881.   ;;
  882.   ;; Note that if nroff spits out error messages, pages will be more than
  883.   ;; 66 lines high, and we'll lose badly.  That's ok because standard
  884.   ;; nroff doesn't do any diagnostics, and the "gnroff" wrapper for groff
  885.   ;; turns off error messages for compatibility.  (At least, it's supposed
  886.   ;; to.)
  887.   ;; 
  888.   (goto-char (point-min))
  889.   ;; first lose the status output
  890.   (let ((case-fold-search t))
  891.     (if (and (not (looking-at "[^\n]*warning"))
  892.          (looking-at "Reformatting.*\n"))
  893.     (delete-region (match-beginning 0) (match-end 0))))
  894.  
  895.   ;; kludge around a groff bug where it won't keep quiet about some
  896.   ;; warnings even with -Wall or -Ww.
  897.   (cond ((looking-at "grotty:")
  898.      (while (looking-at "grotty:")
  899.        (delete-region (point) (progn (forward-line 1) (point))))
  900.      (if (looking-at " *done\n")
  901.          (delete-region (point) (match-end 0)))))
  902.  
  903.   (let ((pages '())
  904.     p)
  905.     ;; collect the page boundary markers before we start deleting, to make
  906.     ;; it easier to strip things out without changing the page sizes.
  907.     (while (not (eobp))
  908.       (forward-line 66)
  909.       (setq pages (cons (point-marker) pages)))
  910.     (setq pages (nreverse pages))
  911.     (while pages
  912.       (goto-char (car pages))
  913.       (set-marker (car pages) nil)
  914.       ;;
  915.       ;; The lines are: 3 blank; footer; 6 blank; header; 3 blank.
  916.       ;; We're in between the previous footer and the following header,
  917.       ;;
  918.       ;; First lose 3 blank lines, the header, and then 3 more.
  919.       ;;
  920.       (setq p (point))
  921.       (skip-chars-forward "\n")
  922.       (delete-region p (point))
  923.       (and (looking-at "[^\n]+\n\n?\n?\n?")
  924.        (delete-region (match-beginning 0) (match-end 0)))
  925.       ;;
  926.       ;; Next lose the footer, and the 3 blank lines after, and before it.
  927.       ;; But don't lose the last footer of the manual entry; that contains
  928.       ;; the "last change" date, so it's not completely uninteresting.
  929.       ;; (Actually lose all blank lines before it; sh(1) needs this.)
  930.       ;;
  931.       (skip-chars-backward "\n")
  932.       (beginning-of-line)
  933.       (if (null (cdr pages))
  934.       nil
  935.     (and (looking-at "[^\n]+\n\n?\n?\n?")
  936.          (delete-region (match-beginning 0) (match-end 0))))
  937.       (setq p (point))
  938.       (skip-chars-backward "\n")
  939.       (if (> (- p (point)) 4)
  940.       (delete-region (+ 2 (point)) p)
  941.     (delete-region (1+ (point)) p))
  942. ;      (and (looking-at "\n\n?\n?")
  943. ;       (delete-region (match-beginning 0) (match-end 0)))
  944.  
  945.       (setq pages (cdr pages)))
  946.     ;;
  947.     ;; Now nuke the extra blank lines at the beginning and end.
  948.     (goto-char (point-min))
  949.     (if (looking-at "\n+")
  950.     (delete-region (match-beginning 0) (match-end 0)))
  951.     (forward-line 1)
  952.     (if (looking-at "\n\n+")
  953.     (delete-region (1+ (match-beginning 0)) (match-end 0)))
  954.     (goto-char (point-max))
  955.     (skip-chars-backward "\n")
  956.     (delete-region (point) (point-max))
  957.     (beginning-of-line)
  958.     (forward-char -1)
  959.     (setq p (point))
  960.     (skip-chars-backward "\n")
  961.     (if (= ?\n (following-char)) (forward-char 1))
  962.     (if (> (point) (1+ p))
  963.     (delete-region (point) p))
  964.     ))
  965.  
  966. ;(defun Manual-nuke-nroff-bs-footers ()
  967. ;  ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
  968. ;  (goto-char (point-min))
  969. ;  (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t)
  970. ;    (replace-match ""))
  971. ;  
  972. ;  ;;
  973. ;  ;; it would appear that we have a choice between sometimes introducing
  974. ;  ;; an extra blank line when a paragraph was broken by a footer, and
  975. ;  ;; sometimes not putting in a blank line between two paragraphs when
  976. ;  ;; a footer appeared right between them.  FMH; I choose the latter.
  977. ;  ;;
  978. ;
  979. ;  ;; Nuke footers: "Printed 12/3/85    27 April 1981    1"
  980. ;  ;;    Sun appear to be on drugz:
  981. ;  ;;     "Sun Release 3.0B  Last change: 1 February 1985     1"
  982. ;  ;;    HP are even worse!
  983. ;  ;;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
  984. ;  ;;    System V (well WICATs anyway):
  985. ;  ;;     "Page 1              (printed 7/24/85)"
  986. ;  ;;    Who is administering PCP to these corporate bozos?
  987. ;  (goto-char (point-min))
  988. ;  (while (re-search-forward
  989. ;       (cond
  990. ;        ((eq system-type 'hpux)
  991. ;         "\n\n?[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*\n")
  992. ;        ((eq system-type 'dgux-unix)
  993. ;         "\n\n?[ \t]*Licensed material--.*Page [0-9]*\n")
  994. ;        ((eq system-type 'usg-unix-v)
  995. ;         "\n\n? *Page [0-9]*.*(printed [0-9/]*)\n")
  996. ;        (t
  997. ;         "\n\n?\\(Printed\\|Sun Release\\) [0-9].*[0-9]\n"))
  998. ;       nil t)
  999. ;    (replace-match ""))
  1000. ;
  1001. ;  ;;    Also, hack X footers:
  1002. ;  ;;     "X Version 11         Last change: Release 5         1"
  1003. ;  (goto-char (point-min))
  1004. ;  (while (re-search-forward "\n\n?X Version [^\n]+\n" nil t)
  1005. ;    (replace-match ""))
  1006. ;
  1007. ;  ;; Crunch blank lines
  1008. ;  (goto-char (point-min))
  1009. ;  (while (re-search-forward "\n\n\n\n*" nil t)
  1010. ;    (replace-match "\n\n"))
  1011. ;  )
  1012.  
  1013. (defun Manual-mouseify-xrefs ()
  1014.   (goto-char (point-min))
  1015.   (forward-line 1)
  1016.   (let ((case-fold-search nil)
  1017.     s e name extent)
  1018.     ;; possibly it would be faster to rewrite this expression to search for
  1019.     ;; a less common sequence first (like "([0-9]") and then back up to see
  1020.     ;; if it's really a match.  This function is 15% of the total time, 13%
  1021.     ;; of which is this call to re-search-forward.
  1022.     (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.]*([0-9][a-zA-Z0-9]*)"
  1023.                   nil t)
  1024.       (setq s (match-beginning 0)
  1025.         e (match-end 0)
  1026.         name (buffer-substring s e))
  1027.       (goto-char s)
  1028.       (skip-chars-backward " \t")
  1029.       (if (and (bolp)
  1030.            (progn (backward-char 1) (= (preceding-char) ?-)))
  1031.       (progn
  1032.         (setq s (point))
  1033.         (skip-chars-backward "-a-zA-Z0-9_.")
  1034.         (setq name (concat (buffer-substring (point) (1- s)) name))
  1035.         (setq s (point))))
  1036.       ;; if there are upper case letters in the section, downcase them.
  1037.       (if (string-match "(.*[A-Z]+.*)$" name)
  1038.       (setq name (concat (substring name 0 (match-beginning 0))
  1039.                  (downcase (substring name (match-beginning 0))))))
  1040.       ;; (setq already-fontified (extent-at s))
  1041.       (setq extent (make-extent s e))
  1042.       (set-extent-property extent 'man (list 'Manual-follow-xref name))
  1043.       (set-extent-property extent 'highlight t)
  1044.       ;; (if (not already-fontified)...
  1045.       (set-extent-face extent 'man-xref)
  1046.       (goto-char e))))
  1047.  
  1048. (defun Manual-follow-xref (&optional name-or-event)
  1049.   "Invoke `manual-entry' on the cross-reference under the mouse.
  1050. When invoked noninteractively, the arg may be an xref string to parse instead."
  1051.   (interactive "e")
  1052.   (if (eventp name-or-event)
  1053.       (let* ((p (event-point name-or-event))
  1054.          (extent (and p (extent-at p
  1055.                  (event-buffer name-or-event)
  1056.                  'highlight)))
  1057.          (data (and extent (extent-property extent 'man))))
  1058.     (if (eq (car-safe data) 'Manual-follow-xref)
  1059.         (eval data)
  1060.       (error "no manual cross-reference there.")))
  1061.     (let ((Manual-match-topic-exactly t)
  1062.       (Manual-query-multiple-pages nil))
  1063.       (or (manual-entry name-or-event)
  1064.       ;; If that didn't work, maybe it's in a different section than the
  1065.       ;; man page writer expected.  For example, man pages tend assume
  1066.       ;; that all user programs are in section 1, but X tends to generate
  1067.       ;; makefiles that put things in section "n" instead...
  1068.       (and (string-match "[ \t]*([^)]+)\\'" name-or-event)
  1069.            (progn
  1070.          (message "No entries found for %s; checking other sections..."
  1071.               name-or-event)
  1072.          (manual-entry
  1073.           (substring name-or-event 0 (match-beginning 0))
  1074.           nil t)))))))
  1075.  
  1076. (defun Manual-popup-menu (&optional event)
  1077.   "Pops up a menu of cross-references in this manual page.
  1078. If there is a cross-reference under the mouse button which invoked this
  1079. command, it will be the first item on the menu.  Otherwise, they are
  1080. on the menu in the order in which they appear in the buffer."
  1081.   (interactive "e")
  1082.   (let ((buffer (current-buffer))
  1083.     (sep "---")
  1084.     (prefix "Show Manual Page for ")
  1085.     xref items)
  1086.     (cond (event
  1087.        (setq buffer (event-buffer event))
  1088.        (let* ((p (event-point event))
  1089.           (extent (and p (extent-at p buffer 'highlight)))
  1090.           (data (and extent (extent-property extent 'man))))
  1091.          (if (eq (car-safe data) 'Manual-follow-xref)
  1092.          (setq xref (nth 1 data))))))
  1093.     (if xref (setq items (list sep xref)))
  1094.     (map-extents #'(lambda (extent ignore)
  1095.              (let ((data (extent-property extent 'man)))
  1096.                (if (and (eq (car-safe data) 'Manual-follow-xref)
  1097.                 (not (member (nth 1 data) items)))
  1098.                (setq items (cons (nth 1 data) items)))
  1099.             nil))
  1100.          buffer)
  1101.     (if (eq sep (car items)) (setq items (cdr items)))
  1102.     (let ((popup-menu-titles nil))
  1103.       (popup-menu
  1104.        (cons "Manual Entry"
  1105.          (mapcar #'(lambda (item)
  1106.              (if (eq item sep)
  1107.                  item
  1108.                            (vector (concat prefix item)
  1109.                                    (list 'Manual-follow-xref item) t)))
  1110.              (nreverse items)))))))
  1111.  
  1112. (defun pager-cleanup-hook ()
  1113.   "cleanup man page if called via $PAGER"
  1114.   (let ((buf-name (or buffer-file-name (buffer-name))))
  1115.     (if (and (or (string-match "^/tmp/man[0-9]+" buf-name)
  1116.              (string-match ".*/man/\\(man\\|cat\\)[1-9a-z]/" buf-name))
  1117.          (not (string-match Manual-bogus-file-pattern buf-name)))
  1118.         (let (buffer manpage)
  1119.           (require 'man)
  1120.           (goto-char (point-min))
  1121.           (setq buffer-read-only nil)
  1122.           (Manual-nuke-nroff-bs)
  1123.           (goto-char (point-min))
  1124.           (if (re-search-forward "[^ \t]")
  1125.           (goto-char (- (point) 1)))
  1126.           (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(")
  1127.           (setq manpage (buffer-substring (match-beginning 1) (match-end 1)))
  1128.         (setq manpage "???"))
  1129.           (setq buffer
  1130.             (rename-buffer
  1131.              (generate-new-buffer-name (concat "*man " manpage "*"))))
  1132.           (setq buffer-file-name nil)
  1133.           (goto-char (point-min))
  1134.           (insert (format "%s\n" buf-name))
  1135.           (goto-char (point-min))
  1136.           (buffer-disable-undo buffer)
  1137.           (set-buffer-modified-p nil)
  1138.           (Manual-mode)
  1139.           ))))
  1140.  
  1141. (add-hook 'server-visit-hook 'pager-cleanup-hook)
  1142. (provide 'man)
  1143.