home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / help-lucid-emacs / text0090.txt < prev    next >
Encoding:
Text File  |  1993-07-14  |  27.8 KB  |  776 lines
  1. And here's an even better version.  I added a man page history list
  2. with an Info-style `l' command, made apropos work properly if the
  3. topic is preceded by "-k", and cleaned up a couple of other things.
  4.  
  5.                                 -- Dave
  6.  
  7.  
  8. ;From
  9. ark1!uakari.primate.wisc.edu!zaphod.mps.ohio-state.edu!usc!ucsd!ucbvax!S
  10. OMEWHERE.BERKELEY.EDU!aks Fri May 18 20:08:09 EDT 1990
  11. ;Article 1962 of comp.emacs:
  12. ;Path:
  13. ark1!uakari.primate.wisc.edu!zaphod.mps.ohio-state.edu!usc!ucsd!ucbvax!S
  14. OMEWHERE.BERKELEY.EDU!aks
  15. ;>From: aks@SOMEWHERE.BERKELEY.EDU (Alan Stebbens)
  16. ;Newsgroups: comp.emacs
  17. ;Subject: Fix to man.el to use MANPATH
  18. ;Message-ID: <9005180023.AA16456@somewhere>
  19. ;Date: 18 May 90 00:23:52 GMT
  20. ;Sender: daemon@ucbvax.BERKELEY.EDU
  21. ;Lines: 350
  22. ;
  23. ;After avoiding the use of M-x manual-entry because it didn't know
  24. ;about alternate man directories, as given by MANPATH, it finally
  25. ;occurred to me that it's silly to not use Emacs to read the man
  26. ;pages, and that it shouldn't be that hard to make "manual-entry"
  27. ;Do The Right Thing.  Well it wasn't very hard, and it wasn't a
  28. ;major rewrite, although it was more than a minor one.
  29. ;
  30. ;The features of this version are:
  31. ;
  32. ;  o  Match multiple man pages using TOPIC as a simple pattern
  33. ;  o  Search unformatted pages, even when formatted matches are found
  34. ;  o  Query the user as to which pages are desired
  35. ;  o  Use of the prefix arg to toggle/bypass the above features
  36. ;  o  Buffers named by the first topic in the buffer
  37. ;  o  Automatic uncompress for compressed man pages (.Z and .z)
  38. ;  o  View the resulting buffer using M-x view mode
  39. ;
  40. ;All the features may be disabled to achieve the (limited)
  41. ;features of the original M-x manual-entry.
  42. ;
  43. ;This is a first cut.  Send improvements, fixes, and comments to me
  44. ;via email.  
  45. ;
  46. ;Alan Stebbens        <aks@hub.ucsb.edu>             (805) 961-3221
  47. ;     Center for Computational Sciences and Engineering (CCSE)
  48. ;          University of California, Santa Barbara (UCSB)
  49. ;           3111 Engineering I, Santa Barbara, CA 93106
  50. ;
  51. ; Modified 16-mar-91 by Jamie Zawinski <jwz@lucid.com> to default the 
  52. ; manual topic to the symbol at point, just like find-tag does.
  53. ;
  54. ; Modified 22-mar-93 by jwz to use multiple fonts and follow xrefs with mouse.
  55. ;
  56. ; Modified 16-apr-93 by Dave Gillespie <daveg@synaptics.com> to make
  57. ; apropos work nicely; add an `l' (Manual-last-page) command; work
  58. ; correctly when bold or italic is unavailable; reuse old buffer if
  59. ; topic is re-selected (in Manual-topic-buffer mode).
  60. ;
  61. ;The following is the complete file; the diffs were so extensive as
  62. ;to be almost as large as the file itself.
  63. ;======================================================================
  64. ;; Read in and display parts of Unix manual.
  65. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  66.  
  67. ;; This file is part of GNU Emacs.
  68.  
  69. ;; GNU Emacs is distributed in the hope that it will be useful,
  70. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  71. ;; accepts responsibility to anyone for the consequences of using it
  72. ;; or for whether it serves any particular purpose or works at all,
  73. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  74. ;; License for full details.
  75.  
  76. ;; Everyone is granted permission to copy, modify and redistribute
  77. ;; GNU Emacs, but only under the conditions described in the
  78. ;; GNU Emacs General Public License.   A copy of this license is
  79. ;; supposed to have been given to you along with GNU Emacs so you
  80. ;; can know your rights and responsibilities.  It should be in a
  81. ;; file named COPYING.  Among other things, the copyright notice
  82. ;; and this notice must be preserved on all copies.
  83. ;;
  84. ;;
  85. ;; Written by Alan K. Stebbens, CCSE, Univ. of CA, Santa Barbara
  86. ;;
  87. ;; This file defines "manual-entry", and the remaining definitions all
  88. ;; begin with "Manual-".  This makes the autocompletion on "M-x man" work.
  89. ;;
  90. ;; Variables of interest:
  91. ;;
  92. ;;    Manual-program
  93. ;;    Manual-topic-buffer
  94. ;;    Manual-buffer-view-mode
  95. ;;    Manual-directory-list
  96. ;;    Manual-formatted-directory-list
  97. ;;    Manual-match-topic-exactly
  98. ;;    Manual-query-multiple-pages
  99. ;;    Manual-page-history
  100. ;;
  101. ;; Last edited:
  102. ;; 
  103. ;; Thu May 17 14:35:17 1990 by Alan Stebbens (aks at somewhere)
  104. ;;      Added force -- allow unformatted search even with
  105. ;;      formatted finds.
  106. ;;      Broke out heavily nested mapcars into the functions
  107. ;;      Manual-select-directories and Manual-select-man-pages.
  108. ;;      Fixed bugs.
  109. ;;      Renamed "Manual.el"
  110. ;;      Added multiple man pages query code.
  111. ;; 
  112. ;; Wed Apr 11 13:42:31 1990 by Alan Stebbens (aks at somewhere)
  113. ;;      Initial rewrite
  114.  
  115. (defvar Manual-program "man" "\
  116. *Name of the program to invoke in order to format the source man pages.")
  117.  
  118. (defvar Manual-topic-buffer t "\
  119. *Non-nil means \\[Manual-entry] should output the manual entry for TOPIC into
  120. a buffer named *TOPIC Manual Entry*, otherwise, it should name the buffer
  121. *Manual Entry*.")
  122.  
  123. (defvar Manual-buffer-view-mode t "\
  124. *Non-nil means that \\[view-buffer] is used to display the output from
  125. \\[Manual-entry]; nil means that the buffer is left in fundamental-mode
  126. in another window.")
  127.  
  128. (defvar Manual-match-topic-exactly t "\
  129. *Non-nil means that \\[manual-entry] will match the given TOPIC exactly, rather
  130. apply it as a pattern.  When this is nil, and \"Manual-query-multiple-pages\" is
  131. non-nil, then \\[manual-entry] will query you for all matching TOPICs.
  132. This variable only has affect on the preformatted man pages (the \"cat\" files),
  133. since the \"man\" command always does exact topic matches.")
  134.  
  135. (defvar Manual-query-multiple-pages nil "\
  136. *Non-nil means that \\[manual-entry] will query the user about multiple man
  137. pages which match the given topic.  The query is done using the function 
  138. \"y-or-n-p\".  If this variable is nil, all man pages with topics matching the
  139. topic given to \\[manual-entry] will be inserted into the temporary buffer.
  140. See the variable \"Manual-match-topic-exactly\" to control the matching.")
  141.  
  142. (defvar Manual-directory-list nil "\
  143. *A list of directories used with the \"man\" command, where each directory
  144. contains a set of \"man?\" and \"cat?\" subdirectories.  If this variable is nil,
  145. it is initialized by \\[Manual-directory-list-init].")
  146.  
  147. (defvar Manual-formatted-directory-list nil "\
  148. A list of directories containing formatted man pages.  Initialized by
  149. \\[Manual-directory-list-init].")
  150.  
  151. (defvar Manual-unformatted-directory-list nil "\
  152. A list of directories containing the unformatted (source) man pages.  
  153. Initialized by \\[Manual-directory-list-init].")
  154.  
  155. (defvar Manual-page-history nil "\
  156. A list of names of previously visited man page buffers.")
  157.  
  158. ;; Manual-directory-list-init
  159. ;; Initialize the directory lists.
  160.  
  161. (defun Manual-directory-list-init (&optional arg) "\
  162. Unless the variable Manual-directory-list is nil, initialize it using the
  163. MANPATH environment variable.  Once this variable is set,
  164. \\[Manual-directory-list-init] will not reinitialize it unless a prefix
  165. argument is given."
  166.   (interactive "P")
  167.   (if arg (setq Manual-directory-list nil))
  168.   (if (null Manual-directory-list)
  169.       (let ((manpath (or (getenv "MANPATH") ""))
  170.         (dirlist nil))
  171.     (while (string-match "\\`[^:]+\\(:*\\)" manpath)
  172.       (setq dirlist (cons (substring manpath 0 (match-beginning 1))
  173.                   dirlist))
  174.       (setq manpath (substring manpath (match-end 0))))
  175.     (setq dirlist (nreverse dirlist))
  176.     (setq Manual-directory-list dirlist)
  177.     (setq Manual-formatted-directory-list nil)
  178.     (setq Manual-unformatted-directory-list nil)))
  179.   (if (null Manual-formatted-directory-list)
  180.       (setq Manual-formatted-directory-list
  181.         (Manual-select-subdirectories Manual-directory-list "cat")))
  182.   (if (null Manual-unformatted-directory-list)
  183.       (setq Manual-unformatted-directory-list
  184.         (Manual-select-subdirectories Manual-directory-list "man"))))
  185.  
  186. ;;
  187. ;; manual-entry  -- The "main" user function
  188. ;;
  189.  
  190. (defun manual-entry (topic &optional arg silent)
  191.   "Display the Unix manual entry (or entries) for TOPIC.  If prefix
  192. arg is given, modify the search according to the value:
  193.   2 = toggle exact matching of the TOPIC name
  194.   3 = force a search of the unformatted man directories
  195.   4 = both 2 and 3
  196. The manual entries are searched according to the variable
  197. Manual-directory-list, which should be a list of directories.  If
  198. Manual-directory-list is nil, \\[Manual-directory-list-init] is
  199. invoked to create this list from the MANPATH environment variable.
  200. See the variable Manual-topic-buffer which controls how the buffer
  201. is named.  See also the variables Manual-match-topic-exactly,
  202. Manual-query-multiple-pages, and Manual-buffer-view-mode."
  203.   (interactive
  204.    (list (let* ((fmh "-A-Za-z0-9_.")
  205.         (default (save-excursion
  206.                (buffer-substring
  207.                 (progn
  208.                   (re-search-backward "\\sw" nil t)
  209.                   (skip-chars-backward fmh) (point))
  210.                 (progn (skip-chars-forward fmh) (point)))))
  211.         (thing (read-string
  212.             (if (equal default "") "Manual entry: "
  213.               (concat "Manual entry: (default " default ") ")))))
  214.        (if (equal thing "") default thing))
  215.      (prefix-numeric-value current-prefix-arg)))
  216.   ;;(interactive "sManual entry (topic): \np")
  217.   (or arg (setq arg 1))
  218.   (Manual-directory-list-init nil)
  219.   (let ((case-fold-search nil)        ; let search be easy
  220.     (temp-buffer-show-function
  221.      (if Manual-buffer-view-mode 'view-buffer temp-buffer-show-function))
  222.     (exact (if (or (= arg 2)(= arg 4))
  223.            (not Manual-match-topic-exactly)
  224.          Manual-match-topic-exactly))
  225.     (force (>= arg 3))
  226.     (sep (make-string 65 ?-))
  227.     section fmtlist manlist apropos-mode)
  228.     (if (and (null section)
  229.          (string-match
  230.           "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
  231.     (setq section (substring topic (match-beginning 2)
  232.                  (match-end 2))
  233.           topic (substring topic (match-beginning 1)
  234.                    (match-end 1)))
  235.       (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
  236.       (setq section "-k"
  237.         topic (substring topic (match-beginning 1)))))
  238.     (if (equal section "-k")
  239.     (setq apropos-mode t)
  240.       (or silent
  241.       (message "Looking for formatted entry for %s%s..."
  242.            topic (if section (concat "(" section ")") "")))
  243.       (setq fmtlist (Manual-select-man-pages
  244.              (Manual-select-directories
  245.               Manual-formatted-directory-list section) 
  246.              topic section exact))
  247.       (if (or force (not fmtlist))
  248.       (progn
  249.         (or silent
  250.         (message "%sooking for unformatted entry for %s%s..."
  251.              (if fmtlist "L" "No formatted entry, l")
  252.              topic (if section (concat "(" section ")") "")))
  253.         (setq manlist (Manual-select-man-pages
  254.                (Manual-select-directories
  255.                 Manual-unformatted-directory-list section)
  256.                topic section exact)))))
  257.     (if (or fmtlist manlist apropos-mode)
  258.     (let* ((name (car (or fmtlist manlist)))
  259.            (bufname (concat
  260.              (if Manual-topic-buffer
  261.                  (if apropos-mode
  262.                  (concat "*" topic " ")
  263.                    (concat "*"
  264.                        (and (string-match "/\\([^/]+\\)$" name)
  265.                         (substring name (match-beginning 1)
  266.                                (match-end 1)))
  267.                        " ")))
  268.              (if apropos-mode
  269.                  "*Manual Apropos*" "*Manual Entry*"))))
  270.       ;; Delete duplicate man pages (a file of the same name in multiple
  271.       ;; directories.)
  272.       (let ((rest (append fmtlist manlist)))
  273.         (while rest
  274.           (let ((rest2 (cdr rest)))
  275.         (while rest2
  276.           (if (equal (file-name-nondirectory (car rest))
  277.                  (file-name-nondirectory (car rest2)))
  278.               (setq fmtlist (delq (car rest2) fmtlist)
  279.                 manlist (delq (car rest2) manlist)))
  280.           (setq rest2 (cdr rest2))))
  281.           (setq rest (cdr rest))))
  282.  
  283.       (if apropos-mode
  284.           (setq manlist (list (format "%s.%s" topic section))))
  285.  
  286.       (if (and Manual-topic-buffer (get-buffer bufname))
  287.           (if temp-buffer-show-function
  288.           (funcall temp-buffer-show-function (get-buffer bufname))
  289.         (display-buffer bufname))
  290.         (with-output-to-temp-buffer bufname
  291.           (buffer-disable-undo standard-output)
  292.           (save-excursion
  293.         (set-buffer standard-output)
  294.         (setq buffer-read-only nil)
  295.         (erase-buffer)
  296.         (let (name start end topic section)
  297.           (while fmtlist        ; insert any formatted files
  298.             (setq name (car fmtlist))
  299.             (goto-char (point-max))
  300.             (setq start (point))
  301.             ;; In case the file can't be read or uncompressed or
  302.             ;; something like that.
  303.             (condition-case ()
  304.             (Manual-insert-man-file name)
  305.               (file-error nil))
  306.             (goto-char (point-max))
  307.             (setq end (point))
  308.             (save-excursion
  309.               (save-restriction
  310.             (message "Cleaning manual entry for %s..."
  311.                  (file-name-nondirectory name))
  312.             (narrow-to-region start end)
  313.             (Manual-nuke-nroff-bs)))
  314.             (if (or (cdr fmtlist) manlist)
  315.             (insert "\n\n" sep "\n"))
  316.             (setq fmtlist (cdr fmtlist)))
  317.           (while manlist        ; process any unformatted files
  318.             (setq name (car manlist))
  319.             (string-match "\\([^/]+\\)\\.\\([^./]+\\)$" name)
  320.             (setq topic (substring name (match-beginning 1)
  321.                        (match-end 1)))
  322.             (setq section (substring name (match-beginning 2)
  323.                          (match-end 2)))
  324.             (message "Invoking man %s %s ..." section topic)
  325.             (setq start (point))
  326.             (if (string-match "roff\\'" Manual-program) ; kludge kludge
  327.             (call-process Manual-program nil t nil
  328.                       "-Tman" "-man" name)
  329.               (call-process Manual-program nil t nil section topic))
  330.             (setq end (point))
  331.             (save-excursion
  332.               (save-restriction
  333.             (message "Cleaning manual entry for %s(%s)..."
  334.                  topic section)
  335.             (narrow-to-region start end)
  336.             (Manual-nuke-nroff-bs apropos-mode)))
  337.             (if (cdr manlist)
  338.             (insert "\n\n" sep "\n"))
  339.             (setq manlist (cdr manlist))))
  340.         (if (< (buffer-size) 80)
  341.             (progn
  342.               (goto-char (point-min))
  343.               (end-of-line)
  344.               (error (buffer-substring 1 (point)))))
  345.         (set-buffer-modified-p nil)
  346.         (Manual-mode)
  347.         )))
  348.       ;; Have to do this here or else view-mode steps on the binding.
  349.       (local-set-key "l" 'Manual-last-page)
  350.       (local-set-key 'button2 'Manual-follow-xref)
  351.       (local-set-key 'button3 'Manual-popup-menu)
  352.       (setq Manual-page-history
  353.         (cons (buffer-name) (delq (buffer-name) Manual-page-history)))
  354.       (message nil)
  355.       t)
  356.       ;; else
  357.       (message "No entries found for %s%s" topic
  358.            (if section (concat "(" section ")") ""))
  359.       nil)))
  360.  
  361. (defvar Manual-mode-map
  362.   (let ((m (make-sparse-keymap)))
  363.     (set-keymap-name m 'Manual-mode-map)
  364.     (define-key m 'button2 'Manual-follow-xref)
  365.     (define-key m 'button3 'Manual-popup-menu)
  366.     m))
  367.  
  368. (defun Manual-mode ()
  369.   (kill-all-local-variables)
  370.   (setq buffer-read-only t)
  371.   (use-local-map Manual-mode-map)
  372.   (setq major-mode 'Manual-mode
  373.     mode-name "Manual"))
  374.  
  375. (defun Manual-last-page ()
  376.   (interactive)
  377.   (while (or (not (get-buffer (car (or Manual-page-history
  378.                        (error "No more history.")))))
  379.          (eq (get-buffer (car Manual-page-history)) (current-buffer)))
  380.     (setq Manual-page-history (cdr Manual-page-history)))
  381.   (switch-to-buffer (car Manual-page-history)))
  382.  
  383.  
  384. ;; Manual-select-subdirectories
  385. ;; Given a DIRLIST and a SUBDIR name, return all subdirectories of the former which
  386. ;; match the latter.
  387.  
  388. (defun Manual-select-subdirectories (dirlist subdir)
  389.   (apply 'append (mapcar '(lambda (dir)
  390.                (and (file-exists-p dir)
  391.                               (mapcar
  392.                    '(lambda (name) (expand-file-name name dir))
  393.                    (sort (file-name-all-completions subdir dir)
  394.                      'string<))))
  395.              dirlist)))
  396.  
  397. ;; Manual-select-directories
  398. ;;
  399. ;; Select from DIRLIST the appropriate directories by SECTION.
  400. ;; Return selected directories in a list.  If SECTION is nil, select
  401. ;; all SECTION directories.
  402.  
  403. (defun Manual-select-directories (dirlist section)
  404.   (delq nil
  405.     (mapcar
  406.      (function (lambda (fmtdir)
  407.              (if (or (not section)
  408.                  (string-match (concat (substring section 0 1)
  409.                            "/$") fmtdir))
  410.              fmtdir)))
  411.      dirlist)))
  412.  
  413. ;; Manual-select-man-pages
  414. ;;
  415. ;; Given a DIRLIST, discover all filenames which complete given the
  416. TOPIC and SECTION.
  417.  
  418. (defun Manual-select-man-pages-iterator (file)
  419.   ;; If Manual-match-topic-exactly is set, then we must make sure
  420.   ;; the completions are exact, except for trailing weird characters
  421.   ;; after the section.
  422.   (if (or (not exact)
  423.       (eq 0 (string-match (concat "^" topic "\\." (or section)) file)))
  424.       (concat dir file)))
  425.  
  426. ;; ## Note: BSD man looks for .../man1/foo.1 and .../man1/$MACHINE/foo.1
  427.  
  428. (defun Manual-select-man-pages (dirlist topic section exact)
  429.   (let ((manlist
  430.      (apply 'append        ; this removes the nulls
  431.        (mapcar (function
  432.             (lambda (dir)
  433.               (if (file-directory-p dir)
  434.               (delq nil
  435.                 (mapcar 'Manual-select-man-pages-iterator
  436.                     (file-name-all-completions
  437.                      (concat topic
  438.                          (if section
  439.                              (concat "." section)))
  440.                      dir)))
  441.             (message "warning: %s is not a directory" dir)
  442.             ;;(sit-for 1)
  443.             nil)))
  444.            dirlist))))
  445.     (if (and manlist Manual-query-multiple-pages)
  446.     (apply 'append
  447.            (mapcar '(lambda (page)
  448.               (if (and page 
  449.                    (y-or-n-p (format "Read %s? " page)))
  450.                   (list page)))
  451.                manlist))
  452.       manlist)))
  453.  
  454. (defun Manual-insert-man-file (name)
  455.   ;; Insert manual file (unpacked as necessary) into buffer
  456.   (if (equal (substring name -2) ".Z")
  457.       (call-process "zcat" nil t nil name)
  458.     (if (equal (substring name -2) ".z")
  459.     (call-process "pcat" nil t nil name)
  460.       (insert-file-contents name))))
  461.  
  462. (defmacro Manual-delete-char (n)
  463.   ;; in v19, delete-char is compiled as a function call, but delete-region
  464.   ;; is byte-coded, so it's much faster.  (We were spending 40% of our time
  465.   ;; in delete-char alone.)
  466.   (list 'delete-region '(point) (list '+ '(point) n)))
  467.  
  468. ;; Hint: BS stands form more things than "back space"
  469. (defun Manual-nuke-nroff-bs (&optional apropos-mode)
  470.   (interactive "*")
  471.   ;;
  472.   ;; turn underlining into italics
  473.   (goto-char (point-min))
  474.   (or (find-face 'man-italic)
  475.       (if (face-differs-from-default-p 'italic)
  476.       (copy-face 'italic 'man-italic)
  477.     (make-face 'man-italic)
  478.     (set-face-underline-p 'man-italic t)))
  479.   (while (re-search-forward "\\(_\b[^\n]\\)+" nil t)
  480.     (let ((s (match-beginning 0))
  481.       (e (match-end 0)))
  482.       (goto-char s)
  483.       (while (< (point) e)
  484.     (setq e (- e 2))
  485.     (Manual-delete-char 2)
  486.     (forward-char 1))
  487.       (set-extent-face (make-extent s (point)) 'man-italic)))
  488.   ;;
  489.   ;; turn overstriking into bold
  490.   (goto-char (point-min))
  491.   (or (find-face 'man-bold)
  492.       (if (face-differs-from-default-p 'bold)
  493.       (copy-face 'bold 'man-bold)
  494.     (copy-face 'highlight 'man-bold)))
  495.   (while (search-forward "\b" nil t)
  496.     (if (save-excursion
  497.       (forward-char -2)
  498.       (looking-at "\\(\\([^\n]\\)\b\\2\\)+"))
  499.     (let* ((s (match-beginning 0))
  500.            (e (match-end 0)))
  501.       (goto-char s)
  502.       (while (< (point) e)
  503.         (setq e (- e 2))
  504.         (Manual-delete-char 2)
  505.         (forward-char 1))
  506.       (set-extent-face (make-extent s e) 'man-bold))))
  507.   ;;
  508.   ;; hack bullets: o^H+ --> +
  509.   (goto-char (point-min))
  510.   (while (search-forward "\b" nil t)
  511.     (Manual-delete-char -2))
  512.  
  513.   (Manual-nuke-nroff-bs-footers)
  514.   ;;
  515.   ;; turn subsection header lines into bold
  516.   (goto-char (point-min))
  517.   (if apropos-mode
  518.       (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t)
  519.     (backward-char 2)
  520.     (delete-backward-char 1))
  521.     (while (re-search-forward "^[^ \t\n]" nil t)
  522.       (set-extent-face (make-extent (match-beginning 0)
  523.                     (progn (end-of-line) (point)))
  524.                'man-bold)))
  525.  
  526.   ;; Zap ESC7,  ESC8, and ESC9
  527.   ;; This is for Sun man pages like "man 1 csh"
  528. ;  (goto-char (point-min))
  529. ;  (while (re-search-forward "\e[789]" nil t)
  530. ;    (replace-match ""))
  531.  
  532.   ;; Nuke blanks lines at start.
  533. ;  (goto-char (point-min))
  534. ;  (skip-chars-forward "\n")
  535. ;  (delete-region (point-min) (point))
  536.  
  537.   (Manual-mouseify-xrefs)
  538.   )
  539.  
  540. (fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
  541.  
  542.  
  543. (defun Manual-nuke-nroff-bs-footers ()
  544.   ;; Nuke headers and footers.
  545.   ;;
  546.   ;; nroff assumes pages are 66 lines high.  We assume that, and that the
  547.   ;; first and last line on each page is expendible.  There is no way to
  548.   ;; tell the difference between a page break in the middle of a paragraph
  549.   ;; and a page break between paragraphs (the amount of extra whitespace
  550.   ;; that nroff inserts is the same in both cases) so this might strip out
  551.   ;; a blank line were one should remain.  I think that's better than
  552.   ;; leaving in a blank line where there shouldn't be one.  (Need I say
  553.   ;; it: FMH.)
  554.   ;;
  555.   ;; Note that if nroff spits out error messages, pages will be more than
  556.   ;; 66 lines high, and we'll lose badly.  That's ok because standard
  557.   ;; nroff doesn't do any diagnostics, and the "gnroff" wrapper for groff
  558.   ;; turns off error messages for compatibility.
  559.   ;; 
  560.   (goto-char (point-min))
  561.   ;; first lose the status output
  562.   (let ((case-fold-search t))
  563.     (if (and (not (looking-at "[^\n]*warning"))
  564.          (looking-at "Reformatting.*\n"))
  565.     (delete-region (match-beginning 0) (match-end 0))))
  566.  
  567.   (let ((pages '())
  568.     p)
  569.     ;; collect the page boundary markers before we start deleting, to make
  570.     ;; it easier to strip things out without changing the page sizes.
  571.     (while (not (eobp))
  572.       (forward-line 66)
  573.       (setq pages (cons (point-marker) pages)))
  574.     (setq pages (nreverse pages))
  575.     (while pages
  576.       (goto-char (car pages))
  577.       (set-marker (car pages) nil)
  578.       ;;
  579.       ;; The lines are: 3 blank; footer; 6 blank; header; 3 blank.
  580.       ;; We're in between the previous footer and the following header,
  581.       ;;
  582.       ;; First lose 3 blank lines, the header, and then 3 more.
  583.       ;;
  584.       (setq p (point))
  585.       (skip-chars-forward "\n")
  586.       (delete-region p (point))
  587.       (and (looking-at "[^\n]+\n\n?\n?\n?")
  588.        (delete-region (match-beginning 0) (match-end 0)))
  589.       ;;
  590.       ;; Next lose the footer, and the 3 blank lines after, and before it.
  591.       ;; But don't lose the last footer of the manual entry; that contains
  592.       ;; the "last change" date, so it's not completely uninteresting.
  593.       ;; (Actually lose all blank lines before it; sh(1) needs this.)
  594.       ;;
  595.       (skip-chars-backward "\n")
  596.       (beginning-of-line)
  597.       (if (null (cdr pages))
  598.       nil
  599.     (and (looking-at "[^\n]+\n\n?\n?\n?")
  600.          (delete-region (match-beginning 0) (match-end 0))))
  601.       (setq p (point))
  602.       (skip-chars-backward "\n")
  603.       (if (> (- p (point)) 4)
  604.       (delete-region (+ 2 (point)) p)
  605.     (delete-region (1+ (point)) p))
  606. ;      (and (looking-at "\n\n?\n?")
  607. ;       (delete-region (match-beginning 0) (match-end 0)))
  608.  
  609.       (setq pages (cdr pages)))
  610.     ;;
  611.     ;; Now nuke the extra blank lines at the beginning and end.
  612.     (goto-char (point-min))
  613.     (if (looking-at "\n+")
  614.     (delete-region (match-beginning 0) (match-end 0)))
  615.     (forward-line 1)
  616.     (if (looking-at "\n\n+")
  617.     (delete-region (1+ (match-beginning 0)) (match-end 0)))
  618.     (goto-char (point-max))
  619.     (skip-chars-backward "\n")
  620.     (delete-region (point) (point-max))
  621.     (beginning-of-line)
  622.     (forward-char -1)
  623.     (setq p (point))
  624.     (skip-chars-backward "\n")
  625.     (if (= ?\n (following-char)) (forward-char 1))
  626.     (if (> (point) (1+ p))
  627.     (delete-region (point) p))
  628.     ))
  629.  
  630. ;(defun Manual-nuke-nroff-bs-footers ()
  631. ;  ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
  632. ;  (goto-char (point-min))
  633. ;  (while (re-search-forward "^
  634. *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t)
  635. ;    (replace-match ""))
  636. ;  
  637. ;  ;;
  638. ;  ;; it would appear that we have a choice between sometimes introducing
  639. ;  ;; an extra blank line when a paragraph was broken by a footer, and
  640. ;  ;; sometimes not putting in a blank line between two paragraphs when
  641. ;  ;; a footer appeared right between them.  FMH; I choose the latter.
  642. ;  ;;
  643. ;
  644. ;  ;; Nuke footers: "Printed 12/3/85    27 April 1981    1"
  645. ;  ;;    Sun appear to be on drugz:
  646. ;  ;;     "Sun Release 3.0B  Last change: 1 February 1985     1"
  647. ;  ;;    HP are even worse!
  648. ;  ;;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
  649. ;  ;;    System V (well WICATs anyway):
  650. ;  ;;     "Page 1              (printed 7/24/85)"
  651. ;  ;;    Who is administering PCP to these corporate bozos?
  652. ;  (goto-char (point-min))
  653. ;  (while (re-search-forward
  654. ;       (cond
  655. ;        ((eq system-type 'hpux)
  656. ;         "\n\n?[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*\n")
  657. ;        ((eq system-type 'dgux-unix)
  658. ;         "\n\n?[ \t]*Licensed material--.*Page [0-9]*\n")
  659. ;        ((eq system-type 'usg-unix-v)
  660. ;         "\n\n? *Page [0-9]*.*(printed [0-9/]*)\n")
  661. ;        (t
  662. ;         "\n\n?\\(Printed\\|Sun Release\\) [0-9].*[0-9]\n"))
  663. ;       nil t)
  664. ;    (replace-match ""))
  665. ;
  666. ;  ;;    Also, hack X footers:
  667. ;  ;;     "X Version 11         Last change: Release 5         1"
  668. ;  (goto-char (point-min))
  669. ;  (while (re-search-forward "\n\n?X Version [^\n]+\n" nil t)
  670. ;    (replace-match ""))
  671. ;
  672. ;  ;; Crunch blank lines
  673. ;  (goto-char (point-min))
  674. ;  (while (re-search-forward "\n\n\n\n*" nil t)
  675. ;    (replace-match "\n\n"))
  676. ;  )
  677.  
  678. (defun Manual-mouseify-xrefs ()
  679.   (goto-char (point-min))
  680.   (forward-line 1)
  681.   (let ((case-fold-search nil)
  682.     s e name extent already-fontified)
  683.     ;; possibly it would be faster to rewrite this expression to search for
  684.     ;; a less common sequence first (like "([0-9]") and then back up to see
  685.     ;; if it's really a match.  This function is 15% of the total time, 13%
  686.     ;; of which is this call to re-search-forward.
  687.     (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.]*([0-9][a-zA-Z]*)" nil t)
  688.       (setq s (match-beginning 0)
  689.         e (match-end 0)
  690.         name (buffer-substring s e))
  691.       (goto-char s)
  692.       (skip-chars-backward " \t")
  693.       (if (and (bolp)
  694.            (progn (backward-char 1) (= (preceding-char) ?-)))
  695.       (progn
  696.         (setq s (point))
  697.         (skip-chars-backward "-a-zA-Z0-9_.")
  698.         (setq name (concat (buffer-substring (point) (1- s)) name))
  699.         (setq s (point))))
  700.       ;; if there are upper case letters in the section, downcase them.
  701.       (if (string-match "(.*[A-Z]+.*)$" name)
  702.       (setq name (concat (substring name 0 (match-beginning 0))
  703.                  (downcase (substring name (match-beginning 0))))))
  704.       (setq already-fontified (extent-at s))
  705.       (setq extent (make-extent s e))
  706.       (set-extent-data extent (list 'Manual-follow-xref name))
  707.       (set-extent-attribute extent 'highlight)
  708.       (if (not already-fontified)
  709.       (set-extent-face extent 'italic))
  710.       (goto-char e))))
  711.  
  712. (defun Manual-follow-xref (&optional name-or-event)
  713.   "Invoke `manual-entry' on the cross-reference under the mouse.
  714. When invoked noninteractively, the arg may be an xref string to parse instead."
  715.   (interactive "e")
  716.   (if (eventp name-or-event)
  717.       (let* ((p (event-point name-or-event))
  718.          (extent (and p (extent-at p
  719.                  (window-buffer (event-window name-or-event))
  720.                  'highlight)))
  721.          (data (and extent (extent-data extent))))
  722.     (if (eq (car-safe data) 'Manual-follow-xref)
  723.         (eval data)
  724.       (error "no manual cross-reference there.")))
  725.     (let ((Manual-match-topic-exactly t)
  726.       (Manual-query-multiple-pages nil))
  727.       (or (manual-entry name-or-event)
  728.       ;; If that didn't work, maybe it's in a different section than the
  729.       ;; man page writer expected.  For example, man pages tend assume
  730.       ;; that all user programs are in section 1, but X tends to generate
  731.       ;; makefiles that put things in section "n" instead...
  732.       (and (string-match "[ \t]*([^)]+)\\'" name-or-event)
  733.            (progn
  734.          (message "No entries found for %s; checking other sections..."
  735.               name-or-event)
  736.          (manual-entry
  737.           (substring name-or-event 0 (match-beginning 0))
  738.           nil t)))))))
  739.  
  740. (defun Manual-popup-menu (&optional event)
  741.   "Pops up a menu of cross-references in this manual page.
  742. If there is a cross-reference under the mouse button which invoked this
  743. command, it will be the first item on the menu.  Otherwise, they are
  744. on the menu in the order in which they appear in the buffer."
  745.   (interactive "e")
  746.   (let ((buffer (current-buffer))
  747.     (sep "---")
  748.     (prefix "Show Manual Page for ")
  749.     xref items)
  750.     (cond (event
  751.        (setq buffer (window-buffer (event-window event)))
  752.        (let* ((p (event-point event))
  753.           (extent (and p (extent-at p buffer 'highlight)))
  754.           (data (and extent (extent-data extent))))
  755.          (if (eq (car-safe data) 'Manual-follow-xref)
  756.          (setq xref (nth 1 data))))))
  757.     (if xref (setq items (list sep xref)))
  758.     (map-extents (function
  759.           (lambda (extent ignore)
  760.             (let ((data (extent-data extent)))
  761.               (if (and (eq (car-safe data) 'Manual-follow-xref)
  762.                    (not (member (nth 1 data) items)))
  763.               (setq items (cons (nth 1 data) items))))
  764.             nil))
  765.          buffer)
  766.     (if (eq sep (car items)) (setq items (cdr items)))
  767.     (popup-menu
  768.      (cons "Manual Entry"
  769.        (mapcar '(lambda (item)
  770.               (if (eq item sep)
  771.               item
  772.             (vector (concat prefix item)
  773.                 (list 'Manual-follow-xref item) t)))
  774.            (nreverse items))))))
  775.  
  776.