home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / packages / man.el < prev    next >
Encoding:
Text File  |  1993-03-14  |  17.3 KB  |  474 lines
  1. ;From ark1!uakari.primate.wisc.edu!zaphod.mps.ohio-state.edu!usc!ucsd!ucbvax!SOMEWHERE.BERKELEY.EDU!aks Fri May 18 20:08:09 EDT 1990
  2. ;Article 1962 of comp.emacs:
  3. ;Path: ark1!uakari.primate.wisc.edu!zaphod.mps.ohio-state.edu!usc!ucsd!ucbvax!SOMEWHERE.BERKELEY.EDU!aks
  4. ;>From: aks@SOMEWHERE.BERKELEY.EDU (Alan Stebbens)
  5. ;Newsgroups: comp.emacs
  6. ;Subject: Fix to man.el to use MANPATH
  7. ;Message-ID: <9005180023.AA16456@somewhere>
  8. ;Date: 18 May 90 00:23:52 GMT
  9. ;Sender: daemon@ucbvax.BERKELEY.EDU
  10. ;Lines: 350
  11. ;
  12. ;After avoiding the use of M-x manual-entry because it didn't know
  13. ;about alternate man directories, as given by MANPATH, it finally
  14. ;occurred to me that it's silly to not use Emacs to read the man
  15. ;pages, and that it shouldn't be that hard to make "manual-entry"
  16. ;Do The Right Thing.  Well it wasn't very hard, and it wasn't a
  17. ;major rewrite, although it was more than a minor one.
  18. ;
  19. ;The features of this version are:
  20. ;
  21. ;  o  Match multiple man pages using TOPIC as a simple pattern
  22. ;  o  Search unformatted pages, even when formatted matches are found
  23. ;  o  Query the user as to which pages are desired
  24. ;  o  Use of the prefix arg to toggle/bypass the above features
  25. ;  o  Buffers named by the first topic in the buffer
  26. ;  o  Automatic uncompress for compressed man pages (.Z and .z)
  27. ;  o  View the resulting buffer using M-x view mode
  28. ;
  29. ;All the features may be disabled to achieve the (limited)
  30. ;features of the original M-x manual-entry.
  31. ;
  32. ;This is a first cut.  Send improvements, fixes, and comments to me
  33. ;via email.  
  34. ;
  35. ;Alan Stebbens        <aks@hub.ucsb.edu>             (805) 961-3221
  36. ;     Center for Computational Sciences and Engineering (CCSE)
  37. ;          University of California, Santa Barbara (UCSB)
  38. ;           3111 Engineering I, Santa Barbara, CA 93106
  39. ;
  40. ; Modified 16-mar-91 by Jamie Zawinski <jwz@lucid.com> to default the 
  41. ; manual topic to the symbol at point, just like find-tag does.
  42. ;
  43. ;The following is the complete file; the diffs were so extensive as
  44. ;to be almost as large as the file itself.
  45. ;======================================================================
  46. ;; Read in and display parts of Unix manual.
  47. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  48.  
  49. ;; This file is part of GNU Emacs.
  50.  
  51. ;; GNU Emacs is distributed in the hope that it will be useful,
  52. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  53. ;; accepts responsibility to anyone for the consequences of using it
  54. ;; or for whether it serves any particular purpose or works at all,
  55. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  56. ;; License for full details.
  57.  
  58. ;; Everyone is granted permission to copy, modify and redistribute
  59. ;; GNU Emacs, but only under the conditions described in the
  60. ;; GNU Emacs General Public License.   A copy of this license is
  61. ;; supposed to have been given to you along with GNU Emacs so you
  62. ;; can know your rights and responsibilities.  It should be in a
  63. ;; file named COPYING.  Among other things, the copyright notice
  64. ;; and this notice must be preserved on all copies.
  65. ;;
  66. ;;
  67. ;; Written by Alan K. Stebbens, CCSE, Univ. of CA, Santa Barbara
  68. ;;
  69. ;; This file defines "manual-entry", and the remaining definitions all
  70. ;; begin with "Manual-".  This makes the autocompletion on "M-x man" work.
  71. ;;
  72. ;; Variables of interest:
  73. ;;
  74. ;;    Manual-program
  75. ;;    Manual-topic-buffer
  76. ;;    Manual-buffer-view-mode
  77. ;;    Manual-directory-list
  78. ;;    Manual-formatted-directory-list
  79. ;;    Manual-match-topic-exactly
  80. ;;    Manual-query-multiple-pages
  81. ;;
  82. ;; Last edited:
  83. ;; 
  84. ;; Thu May 17 14:35:17 1990 by Alan Stebbens (aks at somewhere)
  85. ;;      Added force -- allow unformatted search even with
  86. ;;      formatted finds.
  87. ;;      Broke out heavily nested mapcars into the functions
  88. ;;      Manual-select-directories and Manual-select-man-pages.
  89. ;;      Fixed bugs.
  90. ;;      Renamed "Manual.el"
  91. ;;      Added multiple man pages query code.
  92. ;; 
  93. ;; Wed Apr 11 13:42:31 1990 by Alan Stebbens (aks at somewhere)
  94. ;;      Initial rewrite
  95.  
  96. (defconst Manual-program "man" "\
  97. *Name of the program to invoke in order to format the source man pages.")
  98.  
  99. (defvar Manual-topic-buffer t "\
  100. *Non-nil means \\[Manual-entry] should output the manual entry for TOPIC into
  101. a buffer named *TOPIC Manual Entry*, otherwise, it should name the buffer
  102. *Manual Entry*.")
  103.  
  104. (defvar Manual-buffer-view-mode t "\
  105. *Non-nil means that \\[view-buffer] is used to display the output from
  106. \\[Manual-entry]; nil means that the buffer is left in fundamental-mode
  107. in another window.")
  108.  
  109. (defvar Manual-match-topic-exactly nil "\
  110. *Non-nil means that \\[manual-entry] will match the given TOPIC exactly, rather
  111. apply it as a pattern.  When this is nil, and \"Manual-query-multiple-pages\" is
  112. non-nil, then \\[manual-entry] will query you for all matching TOPICs.
  113. This variable only has affect on the preformatted man pages (the \"cat\" files),
  114. since the \"man\" command always does exact topic matches.")
  115.  
  116. (defvar Manual-query-multiple-pages nil "\
  117. *Non-nil means that \\[manual-entry] will query the user about multiple man
  118. pages which match the given topic.  The query is done using the function 
  119. \"y-or-n-p\".  If this variable is nil, all man pages with topics matching the
  120. topic given to \\[manual-entry] will be inserted into the temporary buffer.
  121. See the variable \"Manual-match-topic-exactly\" to control the matching.")
  122.  
  123. (defvar Manual-directory-list nil "\
  124. *A list of directories used with the \"man\" command, where each directory
  125. contains a set of \"man?\" and \"cat?\" subdirectories.  If this variable is nil,
  126. it is initialized by \\[Manual-directory-list-init].")
  127.  
  128. (defvar Manual-formatted-directory-list nil "\
  129. A list of directories containing formatted man pages.  Initialized by
  130. \\[Manual-directory-list-init].")
  131.  
  132. (defvar Manual-unformatted-directory-list nil "\
  133. A list of directories containing the unformatted (source) man pages.  Initialized
  134. by \\[Manual-directory-list-init].")
  135.  
  136. ;; Manual-directory-list-init
  137. ;; Initialize the directory lists.
  138.  
  139. (defun Manual-directory-list-init (&optional arg) "\
  140. Unless the variable Manual-directory-list is nil, initialize it using the
  141. MANPATH environment variable.  Once this variable is set,
  142. \\[Manual-directory-list-init] will not reinitialize it unless a prefix
  143. argument is given."
  144.   (interactive "P")
  145.   (if arg (setq Manual-directory-list nil))
  146.   (if (null Manual-directory-list)
  147.       (let ((manpath (or (getenv "MANPATH") ""))
  148.         (dirlist nil))
  149.     (while (string-match "\\`[^:]+\\(:*\\)" manpath)
  150.       (setq dirlist (cons (substring manpath 0 (match-beginning 1))
  151.                   dirlist))
  152.       (setq manpath (substring manpath (match-end 0))))
  153.     (setq dirlist (nreverse dirlist))
  154.     (setq Manual-directory-list dirlist)
  155.     (setq Manual-formatted-directory-list nil)
  156.     (setq Manual-unformatted-directory-list nil)))
  157.   (if (null Manual-formatted-directory-list)
  158.       (setq Manual-formatted-directory-list
  159.         (Manual-select-subdirectories Manual-directory-list "cat")))
  160.   (if (null Manual-unformatted-directory-list)
  161.       (setq Manual-unformatted-directory-list
  162.         (Manual-select-subdirectories Manual-directory-list "man"))))
  163.  
  164. ;;
  165. ;; manual-entry  -- The "main" user function
  166. ;;
  167.  
  168. (defun manual-entry (topic &optional arg)
  169.   "Display the Unix manual entry (or entries) for TOPIC.  If prefix
  170. arg is given, modify the search according to the value:
  171.   2 = toggle exact matching of the TOPIC name
  172.   3 = force a search of the unformatted man directories
  173.   4 = both 2 and 3
  174. The manual entries are searched according to the variable
  175. Manual-directory-list, which should be a list of directories.  If
  176. Manual-directory-list is nil, \\[Manual-directory-list-init] is
  177. invoked to create this list from the MANPATH environment variable.
  178. See the variable Manual-topic-buffer which controls how the buffer
  179. is named.  See also the variables Manual-match-topic-exactly,
  180. Manual-query-multiple-pages, and Manual-buffer-view-mode."
  181.   (interactive
  182.    (list (let* ((fmh "-A-Za-z0-9_")
  183.         (default (save-excursion
  184.                (buffer-substring
  185.                 (progn
  186.                   (re-search-backward "\\sw" nil t)
  187.                   (skip-chars-backward fmh) (point))
  188.                 (progn (skip-chars-forward fmh) (point)))))
  189.         (thing (read-string
  190.             (if (equal default "") "Manual entry: "
  191.               (concat "Manual entry: (default " default ") ")))))
  192.        (if (equal thing "") default thing))
  193.      (prefix-numeric-value current-prefix-arg)))
  194.   ;;(interactive "sManual entry (topic): \np")
  195.   (Manual-directory-list-init nil)
  196.   (let ((case-fold-search nil)        ; let search be easy
  197.     (temp-buffer-show-function
  198.      (if Manual-buffer-view-mode 'view-buffer temp-buffer-show-function))
  199.     (exact (if (or (= arg 2)(= arg 4))
  200.            (not Manual-match-topic-exactly)
  201.          Manual-match-topic-exactly))
  202.     (force (>= arg 3))
  203.     section fmtlist manlist apropos-mode)
  204.     (if (and (null section)
  205.          (string-match
  206.           "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
  207.     (setq section (substring topic (match-beginning 2)
  208.                  (match-end 2))
  209.           topic (substring topic (match-beginning 1)
  210.                    (match-end 1))))
  211.     (if (equal section "-k")
  212.     (setq apropos-mode t)
  213.       (message "Looking for formatted entry for %s%s..."
  214.            topic (if section (concat "(" section ")") ""))
  215.       (setq fmtlist (Manual-select-man-pages
  216.              (Manual-select-directories
  217.               Manual-formatted-directory-list section) 
  218.              topic section exact))
  219.       (if (or force (not fmtlist))
  220.       (progn
  221.         (message "%sooking for unformatted entry for %s%s..."
  222.              (if fmtlist "L" "No formatted entry, l")
  223.              topic (if section (concat "(" section ")") ""))
  224.         (setq manlist (Manual-select-man-pages
  225.                (Manual-select-directories
  226.                 Manual-unformatted-directory-list section)
  227.                topic section exact)))))
  228.     (if (or fmtlist manlist apropos-mode)
  229.     (let* ((name (car (or fmtlist manlist)))
  230.            (bufname (concat
  231.              (if Manual-topic-buffer
  232.                  (if apropos-mode
  233.                  (concat "*" topic " ")
  234.                    (concat "*"
  235.                        (and (string-match "/\\([^/]+\\)$" name)
  236.                         (substring name (match-beginning 1)
  237.                                (match-end 1)))
  238.                        " ")))
  239.              (if apropos-mode
  240.                  "*Manual Apropos*" "*Manual Entry*"))))
  241.       ;; Delete duplicate man pages (a file of the same name in multiple
  242.       ;; directories.)
  243.       (let ((rest (append fmtlist manlist)))
  244.         (while rest
  245.           (let ((rest2 (cdr rest)))
  246.         (while rest2
  247.           (if (equal (file-name-nondirectory (car rest))
  248.                  (file-name-nondirectory (car rest2)))
  249.               (setq fmtlist (delq (car rest2) fmtlist)
  250.                 manlist (delq (car rest2) manlist)))
  251.           (setq rest2 (cdr rest2))))
  252.           (setq rest (cdr rest))))
  253.  
  254.       (if apropos-mode
  255.           (setq manlist (list (format "%s.%s" topic section))))
  256.  
  257.       (with-output-to-temp-buffer bufname
  258.         (buffer-disable-undo standard-output)
  259.         (save-excursion
  260.           (set-buffer standard-output)
  261.           (setq buffer-read-only nil)
  262.           (erase-buffer)
  263.           (if fmtlist        ; insert any formatted files
  264.           (mapcar (function (lambda (name)
  265.                  (goto-char (point-max))
  266.                  ;; In case the file can't be read or uncompressed
  267.                  ;; or something like that.
  268.                  (condition-case ()
  269.                  (Manual-insert-man-file name)
  270.                    (file-error nil))
  271.                 (goto-char (point-max))
  272.                 (insert "\n\n-----\n")))
  273.               fmtlist))
  274.           (if manlist        ; process any unformatted files
  275.           (mapcar (function (lambda (name)
  276.                 (let (topic section)
  277.                   (string-match "\\([^/]+\\)\\.\\([^./]+\\)$"
  278.                         name)
  279.                   (setq topic (substring name (match-beginning 1)
  280.                              (match-end 1)))
  281.                   (setq section (substring name
  282.                                (match-beginning 2)
  283.                                (match-end 2)))
  284.                   (message "Invoking man %s %s ..." section topic)
  285.                   (call-process Manual-program nil t nil
  286.                         section topic))
  287.                 (insert "\n\n-----\n")))
  288.               manlist))
  289.           (if (< (buffer-size) 80)
  290.           (progn
  291.             (goto-char (point-min))
  292.             (end-of-line)
  293.             (error (buffer-substring 1 (point)))))
  294.           (message "Cleaning manual entr%s..." 
  295.                (if (> (length (or fmtlist manlist)) 1)
  296.                "ies"
  297.              (concat "y for " topic)))
  298.           (Manual-nuke-nroff-bs)
  299.           (set-buffer-modified-p nil)
  300.           (setq buffer-read-only t)))
  301.       (message ""))
  302.       ;; else
  303.       (message "No entries found for %s%s" topic
  304.            (if section (concat "(" section ")") "")))))
  305.  
  306. ;; Manual-select-subdirectories
  307. ;; Given a DIRLIST and a SUBDIR name, return all subdirectories of the former which
  308. ;; match the latter.
  309.  
  310. (defun Manual-select-subdirectories (dirlist subdir)
  311.   (apply 'append (mapcar '(lambda (dir)
  312.                (and (file-exists-p dir)
  313.                               (mapcar
  314.                    '(lambda (name) (expand-file-name name dir))
  315.                    (sort (file-name-all-completions subdir dir)
  316.                      'string<))))
  317.              dirlist)))
  318.  
  319. ;; Manual-select-directories
  320. ;;
  321. ;; Select from DIRLIST the appropriate directories by SECTION.
  322. ;; Return selected directories in a list.  If SECTION is nil, select
  323. ;; all SECTION directories.
  324.  
  325. (defun Manual-select-directories (dirlist section)
  326.   (delq nil
  327.     (mapcar
  328.      (function (lambda (fmtdir)
  329.              (if (or (not section)
  330.                  (string-match (concat (substring section 0 1)
  331.                            "/$") fmtdir))
  332.              fmtdir)))
  333.      dirlist)))
  334.  
  335. ;; Manual-select-man-pages
  336. ;;
  337. ;; Given a DIRLIST, discover all filenames which complete given the TOPIC and SECTION.
  338.  
  339. (defun Manual-select-man-pages-iterator (file)
  340.   ;; If Manual-match-topic-exactly is set, then we must make sure
  341.   ;; the completions are exact, except for trailing weird characters
  342.   ;; after the section.
  343.   (if (or (not exact)
  344.       (eq 0 (string-match (concat "^" topic "\\." (or section)) file)))
  345.       (concat dir file)))
  346.  
  347. (defun Manual-select-man-pages (dirlist topic section exact)
  348.   (let ((manlist
  349.      (apply 'append        ; this removes the nulls
  350.        (mapcar (function
  351.             (lambda (dir)
  352.               (if (file-directory-p dir)
  353.               (delq nil
  354.                 (mapcar 'Manual-select-man-pages-iterator
  355.                     (file-name-all-completions
  356.                      (concat topic
  357.                          (if section
  358.                              (concat "." section)))
  359.                      dir)))
  360.             (message "warning: %s is not a directory" dir)
  361.             ;;(sit-for 1)
  362.             nil)))
  363.            dirlist))))
  364.     (if (and manlist Manual-query-multiple-pages)
  365.     (apply 'append
  366.            (mapcar '(lambda (page)
  367.               (if (and page 
  368.                    (y-or-n-p (format "Read %s? " page)))
  369.                   (list page)))
  370.                manlist))
  371.       manlist)))
  372.  
  373. ;; Hint: BS stands form more things than "back space"
  374. (defun Manual-nuke-nroff-bs ()
  375.   (interactive "*")
  376.   ;; turn underlining into italics
  377.   (goto-char (point-min))
  378.   (while (re-search-forward "\\(\\(_\^H.\\) ?\\)+" nil t)
  379.     (set-extent-face (make-extent (match-beginning 0) (match-end 0))
  380.              'italic))
  381.   ;; Nuke underlining and overstriking (only by the same letter)
  382.   (goto-char (point-min))
  383.   (while (search-forward "\b" nil t)
  384.     (let* ((preceding (char-after (- (point) 2)))
  385.        (following (following-char)))
  386.       (cond ((or (= preceding following)    ; x\bx
  387.          (= preceding ?\_))         ; _\b
  388.          (delete-char -2))
  389.         ((or (= following ?\_)        ; \b_
  390.          (= following ?\ ))             ; \b(SPACE)
  391.          (delete-region (1- (point)) (1+ (point))))
  392.         (t (delete-char -1)))))        ; \b by itself (remove it)
  393.  
  394.   ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
  395.   (goto-char (point-min))
  396.   (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t)
  397.     (replace-match ""))
  398.   
  399.   (goto-char (point-min))
  400.   (if (looking-at "Reformatting page.*$")
  401.       (replace-match ""))
  402.   
  403.   ;; Crunch blank lines
  404.   (goto-char (point-min))
  405.   (while (re-search-forward "\n\n\n\n*" nil t)
  406.     (replace-match "\n\n"))
  407.  
  408.   ;;
  409.   ;; it would appear that we have a choice between sometimes introducing
  410.   ;; an extra blank line when a paragraph was broken by a footer, and
  411.   ;; sometimes not putting in a blank line between two paragraphs when
  412.   ;; a footer appeared right between them.  FMH; I choose the latter.
  413.   ;;
  414.  
  415.   ;; Nuke footers: "Printed 12/3/85    27 April 1981    1"
  416.   ;;    Sun appear to be on drugz:
  417.   ;;     "Sun Release 3.0B  Last change: 1 February 1985     1"
  418.   ;;    HP are even worse!
  419.   ;;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
  420.   ;;    System V (well WICATs anyway):
  421.   ;;     "Page 1              (printed 7/24/85)"
  422.   ;;    Who is administering PCP to these corporate bozos?
  423.   (goto-char (point-min))
  424.   (while (re-search-forward
  425.        (cond
  426.         ((eq system-type 'hpux)
  427.          "\n\n?[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*\n")
  428.         ((eq system-type 'dgux-unix)
  429.          "\n\n?[ \t]*Licensed material--.*Page [0-9]*\n")
  430.         ((eq system-type 'usg-unix-v)
  431.          "\n\n? *Page [0-9]*.*(printed [0-9/]*)\n")
  432.         (t
  433.          "\n\n?\\(Printed\\|Sun Release\\) [0-9].*[0-9]\n"))
  434.        nil t)
  435.     (replace-match ""))
  436.  
  437.   ;;    Also, hack X footers:
  438.   ;;     "X Version 11         Last change: Release 5         1"
  439.   (goto-char (point-min))
  440.   (while (re-search-forward "\n\n?X Version [^\n]+\n" nil t)
  441.     (replace-match ""))
  442.  
  443.   ;; Zap ESC7,  ESC8, and ESC9
  444.   ;; This is for Sun man pages like "man 1 csh"
  445.   (goto-char (point-min))
  446.   (while (re-search-forward "\e[789]" nil t)
  447.     (replace-match ""))
  448.  
  449.   ;; Nuke blanks lines at start.
  450.   (goto-char (point-min))
  451.   (skip-chars-forward "\n")
  452.   (delete-region (point-min) (point))
  453.  
  454.   ;; turn header lines into bold
  455.   (goto-char (point-min))
  456.   (while (re-search-forward "^[^ \t\n]" nil t)
  457.     (set-extent-face (make-extent (match-beginning 0)
  458.                   (progn (end-of-line) (point)))
  459.              'bold))
  460.   )
  461.  
  462. (fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
  463.  
  464.  
  465. (defun Manual-insert-man-file (name)
  466.   ;; Insert manual file (unpacked as necessary) into buffer
  467.   (if (equal (substring name -2) ".Z")
  468.       (call-process "zcat" nil t nil name)
  469.     (if (equal (substring name -2) ".z")
  470.     (call-process "pcat" nil t nil name)
  471.       (insert-file-contents name))))
  472.  
  473.  
  474.