home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / lispdir.el < prev    next >
Encoding:
Text File  |  1993-03-08  |  18.5 KB  |  473 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;; lispdir.el --- Lisp Code Directory formatter and apropos
  3. ;; Authors         : Ashwin Ram (Ram-Ashwin@cs.yale.edu)
  4. ;;                 ; Dave Sill (de5@ornl.gov)
  5. ;;                 ; David Lawrence (tale@pawl.rpi.edu)
  6. ;;           ; Noah Friedman (friedman@ai.mit.edu)
  7. ;;           ; Joe Wells (jbw@cs.bu.edu)
  8. ;;                 ; Dave Brennan (brennan@hal.com)
  9. ;;           ; Eric Raymond (eric@snark.thyrsus.com)
  10. ;; Created On      : Wed Jan 25, 1989
  11. ;; Last Modified By: Dave Brennan
  12. ;; Last Modified On: Tue Mar  9 12:47:13 1993
  13. ;; Update Count    : 56
  14. ;; Status          : No known bugs.
  15. ;; Version         : 4.3
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;
  18. ;;- Add the following lines to ~/.emacs or an equivalent  (w/o  ";;-"  !):
  19. ;;
  20. ;;-  (autoload 'format-lisp-code-directory "lispdir" nil t)
  21. ;;-  (autoload 'lisp-dir-apropos "lispdir" nil t)
  22. ;;-  (autoload 'lisp-dir-retrieve "lispdir" nil t)
  23. ;;-  (autoload 'lisp-dir-verify "lispdir" nil t)
  24. ;;
  25. ;; Other routines of interest to programmers:
  26. ;;
  27. ;;    insert-lcd-headers
  28. ;;    submit-lcd-entry
  29. ;;
  30. ;;See the doc strings of the individual functions for more documentation.
  31.  
  32. ;; History
  33.  
  34. ;; 09-Mar-1993          Joe Wells <jbw@cs.bu.edu>, Dave Brennan
  35. ;;    Added code to break long archive name lines between the hostname and
  36. ;;    the filename to avoid exceeding lisp-dir-fill-column characters.
  37.  
  38. ;; 23-Jun-1992        Dave Brennan
  39. ;;    Added strategic "(require 'crypt)" statements as suggested by
  40. ;;    Martin Boyer.
  41.  
  42. ;; 23-Mar-1992        Dave Brennan
  43. ;;    Just use the file name in the variable lisp-code-directory instead
  44. ;;    of screwy " *LCD-datafile*" name.  Merged in Eric's changes from
  45. ;;    November.  (See next entry.)
  46.  
  47. ;; 26-Nov-1992        Eric Raymond
  48. ;;    Added insert-lcd-headers, submit-lcd-entry.  Isolated access-method code.
  49. ;;    Introduced lcd-locations variable.  Added progress indication to format
  50. ;;    so the hapless luser doesn't just see a frozen screen for 10 minutes.
  51. ;;    Added entry point list to header for the enlightenment of newbies.
  52.  
  53. ;; 22-Aug-1991        Dave Brennan
  54. ;;    Only load LCD-datafile when it is first referenced to make it faster.
  55. ;;    To force a reload kill the buffer " *LCD-datafile*" (note the space).
  56.  
  57. ;; 03-Aug-1991        Dave Brennan
  58. ;;    If no matching entry is found print message in minibuffer instead of
  59. ;;    displaying an empty apropos buffer.  If the apropos buffer exists
  60. ;;    it is not modified.
  61.  
  62. ;; 19-Jul-1991        Dave Sill    
  63. ;;    Added lisp-code-retrieve and lisp-code-verify using ange-ftp.
  64.  
  65. ;; 18-Jul-1991        Dave Sill    
  66. ;;    Added "Archive" to Ram/Tale header. (Joe Wells <jbw@maverick.uswest.com>)
  67.  
  68. ;; 12-Jul-1991        Noah Friedman (friedman@ai.mit.edu)
  69. ;;    Modified format-lisp-code-directory to use find-file-noselect in
  70. ;;    another buffer, then insert-buffer.  The reason for this is that
  71. ;;    insert-file has no hooks, and so cannot (for example) uncompress
  72. ;;    a compressed file.  This loses if I want to grab LCD-datafile.Z
  73. ;;    using ange-ftp.
  74.  
  75. ;; 20-Jun-1991        de5
  76. ;;    Mostly cosmetic changes in prompts and buffer names.
  77.  
  78. ;; 27-Jun-1989        dsill
  79. ;;    Added support for "archive" field containing anonymous FTP location.
  80.  
  81. ;; 28-Feb-1989        dsill    
  82. ;;    Changed format-lcd-line-Sill to be smart about GNU-distributed code.
  83. ;;    Changed format-lcd-line-Sill to take advantage of 12-char max name.
  84.  
  85. ;; 22-Feb-1989        dsill    
  86. ;;    Changed format-lisp-code-directory and lisp-dir-apropos to call the
  87. ;;      line formatter indirectly.  The variable 
  88. ;;      format-lisp-code-directory-line contains a function to format a single
  89. ;;      line, and format-lcd-line-Ram, format-lcd-line-tale, and
  90. ;;      format-lcd-line-Sill are the three possibilities at this time.
  91.  
  92. ;; 20-Feb-1989        tale    
  93. ;;    changed file's name to lispdir.el
  94. ;;    format-lisp-code-directory makes separate buffer
  95. ;;    removed lisp-dir-apropos-buffer -- why use more space in memory?
  96. ;;    added lisp-dir-[apropos-]hook
  97. ;;      (I like (setq lisp-dir-hook 'delete-other-windows))
  98. ;;    other aesthetic changes
  99.  
  100. ;; 16-Feb-1989        dsill    
  101. ;;    Added lisp-dir-apropos function
  102.  
  103. (require 'picture)            ;provides move-to-column-force
  104.  
  105. ;; *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  106. ;; You'll need ange-ftp and crypt (for uncompressing) to use the name
  107. ;; below.  For better performance put the LCD-datafile on a local sytem.
  108. ;; Do not use uncompress.el because it (incorrectly) renames a buffer
  109. ;; after uncompressing it, which means that each apropos will wind up
  110. ;; ftping the LCD-datafile again.  Use Kyle Jones' crypt code which
  111. ;; is also available from the archive.
  112. ;; *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  113.  
  114. ;; Some users don't read warnings...
  115. (if (and (featurep 'ange-ftp) (fboundp 'find-compressed-version))
  116.     (progn
  117.       (message
  118.        "Don't use uncompress.el with lispdir.el.  See warning in lispdir.el.")
  119.       (sit-for 5)))
  120.  
  121. (defvar lisp-code-directory
  122.  "/anonymous@archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/LCD-datafile.Z"
  123.   "*Database of free lisp code.  Entries are in the form:
  124. Name|Author|Contact|Description|Date|Version|Archive")
  125.  
  126. (defvar format-lisp-code-directory-line 'format-lcd-line-Sill
  127.   "*Function that formats one line of GNU Emacs Lisp Code Directory.\n
  128. Provided as a variable for customizability.  Should not insert
  129. final newline.")
  130.  
  131. (defvar lisp-code-directory-header 'lcd-header-Sill
  132.   "*Function that inserts header appropriate for 
  133. format-lisp-code-directory-line.")
  134.  
  135. (defvar elisp-archive-host "archive.cis.ohio-state.edu"
  136.   "*Site with elisp archive available via anonymous ftp.")
  137.  
  138. (defvar elisp-archive-directory "/pub/gnu/emacs/elisp-archive/"
  139.   "*Root directory of elisp archives on elisp-archive-host.")
  140.  
  141. (defvar elisp-submission-address "elisp-archive@cis.ohio-state.edu"
  142.   "*Submission mail address for elisp archive.")
  143.  
  144. (defvar lisp-dir-expand-filename nil
  145.   "*If nil do not expand "~" to the elisp archive.  Non-nil means expand.")
  146.  
  147. (defvar lisp-dir-fill-column 76
  148.   "*Column beyond which formatted LCD entries are wrapped.  A value of
  149. nil means don't wrap.")
  150.  
  151. ;; Access-method-dependent code begins here
  152. ;;
  153. ;; Theory: some day soon we'll have a couple of different remote-access
  154. ;; methods --- at least, one through FTP and one through an FTP request server
  155. ;; accessed by mail (I'd have implemented this already if I could remember
  156. ;; the address of the one at Princeton!).  Isolate all that stuff as cases
  157. ;; of the implementation of these functions.
  158.  
  159. (defun remote-exists-p (file)
  160.   ;; Check for the existence of a file at a remote ftp site
  161.   (require 'ange-ftp)
  162.   (require 'crypt)
  163.   (ange-ftp-file-exists-p (concat "/anonymous@" file)))
  164.  
  165. (defun remote-find-file (file)
  166.   ;; Remote-fetch a file
  167.   (require 'ange-ftp)
  168.   (require 'crypt)
  169.   (find-file-noselect (concat "/anonymous@" file)))
  170.  
  171. ;; Access-method-dependent code ends here
  172.  
  173. (defun format-lisp-code-directory ()
  174.    "Convert GNU Emacs Lisp Code Directory into something a human could read.
  175. Calls value of lisp-dir-hook with no args if that value is non-nil."
  176.    (interactive)
  177.    (pop-to-buffer "*GNU Emacs Lisp Code Directory*")
  178.    (fundamental-mode)
  179.    (setq buffer-read-only nil)
  180.    (erase-buffer)
  181.    (buffer-flush-undo (current-buffer))
  182.    (lisp-dir-insert-datafile)
  183.    (insert " GNU Emacs Lisp code directory.  " (current-time-string) ".\n\n")
  184.    (message "Formatting %s ..." lisp-code-directory)
  185.    (delete-region (progn (beginning-of-line) (point))
  186.           (progn (end-of-line) (point)))
  187.    (funcall lisp-code-directory-header)
  188.    (while (re-search-forward
  189.        "\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)" nil t)
  190.       (let ((name (buffer-substring (match-beginning 1) (match-end 1)))
  191.             (author (buffer-substring (match-beginning 2) (match-end 2)))
  192.             (contact (buffer-substring (match-beginning 3) (match-end 3)))
  193.             (description (buffer-substring (match-beginning 4) (match-end 4)))
  194.             (date (buffer-substring (match-beginning 5) (match-end 5)))
  195.             (version (buffer-substring (match-beginning 6) (match-end 6)))
  196.         (archive (buffer-substring (match-beginning 7) (match-end 7))))
  197.        (delete-region (progn (beginning-of-line) (point))
  198.     (progn (end-of-line) (point)))
  199.        (funcall format-lisp-code-directory-line
  200.     name author contact description date version archive)))
  201.    (goto-char (point-min))
  202.    (center-line)
  203.    (message "Formatting %s ... done" lisp-code-directory)
  204.    (set-buffer-modified-p nil)
  205.    (run-hooks 'lisp-dir-hook))
  206.  
  207. (defun lisp-dir-apropos (topic)
  208.   "Display entries in Lisp Code Directory for TOPIC in separate window.
  209. Calls value of lisp-dir-apropos-hook with no args if that value is non-nil."
  210.   (interactive (list
  211.         (read-string
  212.          (concat "GELCD apropos regexp (" (current-word) "): "))))
  213.   (if (equal "" topic) (setq topic (current-word)))
  214.   (save-excursion
  215.     (let ((lisp-code-directory-tmp-buffer
  216.        (get-buffer-create "*lcd-working*")))
  217.       (message "Searching for %s ..." topic)
  218.       (set-buffer lisp-code-directory-tmp-buffer)
  219.       (lisp-dir-insert-datafile)
  220.       (delete-non-matching-lines topic)
  221.       (set-buffer-modified-p nil)
  222.       (if (= (point-min) (point-max))
  223.       (progn
  224.         (kill-buffer lisp-code-directory-tmp-buffer)
  225.         (message "No entries matching `%s' were found." topic))
  226.     (set-buffer
  227.      (get-buffer-create "*GNU Emacs Lisp Code Directory Apropos*"))
  228.     (fundamental-mode)
  229.     (setq buffer-read-only nil)
  230.     (erase-buffer)
  231.     (buffer-flush-undo (current-buffer))
  232.     (insert-buffer lisp-code-directory-tmp-buffer)
  233.     (kill-buffer lisp-code-directory-tmp-buffer)
  234.     (insert "GNU Emacs Lisp Code Directory Apropos -- \"" topic "\"\n")
  235.     (if (not lisp-dir-expand-filename)
  236.         (insert "\"~/\" refers to "
  237.             elisp-archive-host ":" elisp-archive-directory))
  238.     (insert "\n\n")
  239.     (backward-char 1)
  240.     (funcall lisp-code-directory-header)
  241.     (while (re-search-forward
  242.     "\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)" nil t)
  243.       (let ((name (buffer-substring (match-beginning 1) (match-end 1)))
  244.         (author (buffer-substring (match-beginning 2) (match-end 2)))
  245.         (contact (buffer-substring (match-beginning 3) (match-end 3)))
  246.         (description (buffer-substring (match-beginning 4) (match-end 4)))
  247.         (date (buffer-substring (match-beginning 5) (match-end 5)))
  248.         (version (buffer-substring (match-beginning 6) (match-end 6)))
  249.         (archive (buffer-substring (match-beginning 7) (match-end 7))))
  250.         (delete-region (progn (beginning-of-line) (point))
  251.                (progn (end-of-line) (point)))
  252.         (funcall format-lisp-code-directory-line
  253.              name author contact description date version archive)))
  254.     (goto-char (point-min))
  255.     (center-line)
  256.     (message "Searching for %s ... done" topic)
  257.     (set-buffer-modified-p nil)
  258.     (display-buffer "*GNU Emacs Lisp Code Directory Apropos*")
  259.     (run-hooks 'lisp-dir-apropos-hook)))))
  260.  
  261. ;; Read in lisp code directory file in another buffer (using
  262. ;; find-file-noselect, so that usual find-file-hooks will be run,
  263. ;; like find-crypt-file-hook). 
  264.  
  265. (defun lisp-dir-insert-datafile ()
  266.   "Insert the LCD-database in the current buffer.  The datebase is found
  267. in the file named by the lisp-code-directory variable."
  268.   (if (string-match "\\.Z$" lisp-code-directory)
  269.       (require 'crypt))
  270.   (insert-buffer (find-file-noselect lisp-code-directory))
  271.   (setq buffer-read-only nil))
  272.  
  273. (defun format-lcd-line-Ram
  274.   (name author contact description date version archive)
  275.   "Columnar formatter for Lisp code directory that tries to use as few lines
  276. as possible.  Doesn't fit Contact within first 80 columns."
  277.    (insert-at-column 1  name)
  278.    (insert-at-column 17 description)
  279.    (insert-at-column 49 author)
  280.    (insert-at-column 65 date)
  281.    (insert-at-column 74 "/")
  282.    (insert-at-column 75 version)
  283.    (insert-at-column 84 contact))
  284.  
  285. (defun format-lcd-line-tale
  286.   (name author contact description date version archive)
  287.   "Multi-line columnar formatter for Lisp Code Directory that tries not
  288. to write anything past column 79."
  289.    (insert-at-column 0  name)
  290.    (insert-at-column 17 description)
  291.    (insert-at-column 56 author)
  292.    (insert-at-column 4  contact)
  293.    (insert-at-column 56 date)
  294.    (insert-at-column 72 version))
  295.  
  296. (defun format-lcd-line-Sill
  297.   (name author contact description date version archive)
  298.   "Multi-line non-columnar line formatter for Lisp Code Directory."
  299.   (insert-at-column 0 name)
  300.   (if (not (equal version ""))
  301.       (insert " (" version ")"))
  302.   (insert-at-column 22 date)
  303.   (insert "\n")
  304.   (if (and (string-match "[0-9]+\.[0-9]+ dist" contact)
  305.        (equal author "FSF"))
  306.       (insert-at-column 5 contact)
  307.     (progn
  308.       (insert-at-column 5 author)
  309.       (insert ", <" contact ">\n")
  310.       (if (not (equal archive ""))
  311.       (progn
  312.         (if lisp-dir-expand-filename
  313.         (progn
  314.           (if (and (string-match "~" archive)
  315.                (= 0 (string-match "~" archive)))
  316.               (setq archive
  317.                 (concat elisp-archive-host ":"
  318.                     elisp-archive-directory
  319.                     (substring archive 2))))))
  320.         (insert-at-column 5 archive)
  321.         ;; jbw: Added code to break long archive name lines between
  322.         ;; jbw: the hostname and the filename to avoid exceeding 80
  323.         ;; jbw: characters.
  324.         (cond ((and lisp-dir-fill-column
  325.             (> (current-column) lisp-dir-fill-column))
  326.            (move-to-column 5)
  327.            (cond ((looking-at "[-A-Za-z0-9]+\\(\\.[-A-Za-z0-9]+\\)+:")
  328.               (goto-char (match-end 0))
  329.               (insert "\n       ")
  330.               (end-of-line 1)))))
  331.         ))))
  332.   (insert-at-column 5 description))
  333.  
  334. (defun lcd-header-Ram/tale ()
  335.   "Inserts header for column-formatted Lisp Code Directory."
  336.   (funcall format-lisp-code-directory-line
  337.     "Name" "Author" "Contact" "Description" "Date" "Version" "Archive")
  338.   (insert "\n")
  339.   (insert-char ?- 79)
  340. )
  341.  
  342. (defun lcd-header-Sill ()
  343.   "Inserts empty header for non-columnar Lisp Code Directory"
  344. )
  345.  
  346. (defun insert-at-column (col string)
  347.    (if (> (current-column) col) (insert "\n"))
  348.    (move-to-column-force col)
  349.    (insert string))
  350.  
  351. (defun lisp-dir-retrieve (name)
  352.   "Retrieves a copy of the NAMEd package.  The NAME must be an exact match.
  353. Calls value of lisp-dir-retrieve-hook with no args if that value is non-nil."
  354.   (interactive (list
  355.         (read-string
  356.          (concat "GELCD retrieve (" (current-word) "): "))))
  357.   (if (equal "" name) (setq name (current-word)))
  358.   (save-excursion
  359.     (set-buffer (get-buffer-create (concat "GELCD-" name)))
  360.     (fundamental-mode)
  361.     (setq buffer-read-only nil)
  362.     (erase-buffer)
  363.     (lisp-dir-insert-datafile)
  364.     (message "Searching for %s ..." name)
  365.     (delete-non-matching-lines (concat "^" (regexp-quote name) "|"))
  366.     (let ((matches (count-lines (point-min) (point-max))))
  367.       (cond ((= matches 0)
  368.              (progn
  369.                (message "No match found for %s" name)
  370.                nil))
  371.             ((> matches 1)
  372.              (progn
  373.                (message "Multiple matches found for %s, should be unique" name)
  374.                nil))
  375.             (t
  376.              (re-search-forward
  377.               "\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)" nil t)
  378.              (let ((archive (buffer-substring (match-beginning 7) (match-end 7))))
  379.                (if (not (equal archive ""))
  380.                    (progn
  381.                      (if (and (string-match "~" archive)
  382.                               (= 0 (string-match "~" archive)))
  383.                          (setq archive (concat elisp-archive-host ":"
  384.                                                elisp-archive-directory
  385.                                                (substring archive 2))))))
  386.                (erase-buffer)
  387.                (let ((lisp-code-directory-tmp-buffer
  388.               (remote-find-file archive)))
  389.                  (insert-buffer lisp-code-directory-tmp-buffer)
  390.                  (kill-buffer lisp-code-directory-tmp-buffer)))
  391.              (goto-char (point-min))
  392.              (display-buffer (concat "GELCD-" name))
  393.              (run-hooks 'lisp-dir-retrieve-hook))))))
  394.  
  395. (defun lisp-dir-verify (name)
  396.   "Verifies the archive location of the NAMEd package using ange-ftp."
  397.   (interactive (list
  398.         (read-string
  399.          (concat "GELCD verify (" (current-word) "): "))))
  400.   (if (equal "" name) (setq name (current-word)))
  401.   (save-excursion
  402.     (set-buffer (get-buffer-create "GELCD-verify"))
  403.     (fundamental-mode)
  404.     (setq buffer-read-only nil)
  405.     (erase-buffer)
  406.     (lisp-dir-insert-datafile)
  407.     (message "Searching for %s ..." name)
  408.     (delete-non-matching-lines (concat "^" name "|"))
  409.     (let ((matches (count-lines (point-min) (point-max))))
  410.       (cond ((= matches 0)
  411.              (progn
  412.                (message "No match found for %s" name)
  413.                nil))
  414.             ((> matches 1)
  415.              (progn
  416.                (message "Multiple matches found for %s, should be unique" name)
  417.                nil))
  418.             (t
  419.              (re-search-forward
  420.               "\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)" nil t)
  421.              (let ((archive (buffer-substring (match-beginning 7) (match-end 7))))
  422.                (if (not (equal archive ""))
  423.                    (progn
  424.                      (if (and (string-match "~" archive)
  425.                               (= 0 (string-match "~" archive)))
  426.                          (setq archive (concat elisp-archive-host ":"
  427.                                                elisp-archive-directory
  428.                                                (substring archive 2))))
  429.                      (if (remote-exists-p archive)
  430.                          (message "Package %s is available from: %s" name archive)
  431.                        (message "Package %s is supposed to be available but isn't." name)))
  432.                  (message "Package %s is not archived." name))))))))
  433.  
  434. ;; Snatched from unix-apropos by Henry Kautz
  435. (defun current-word ()
  436.    "Word cursor is over, as a string."
  437.    (save-excursion
  438.       (let (beg end)
  439.      (re-search-backward "\\w" nil 2)
  440.      (re-search-backward "\\b" nil 2)
  441.      (setq beg (point))
  442.      (re-search-forward "\\w*\\b" nil 2)
  443.      (setq end (point))
  444.      (buffer-substring beg end))))
  445. (defun insert-lcd-headers (name version description)
  446.   "Query user for contents of LCD entry.  Insert them in the current buffer"
  447.   (interactive "sPackage name: \nsVersion: \nsDescription: ")
  448.   (beginning-of-line)
  449.   (insert
  450.    ";;\n"
  451.    ";; Purpose of this package:\n;;\n"
  452.    ";; Installation instructions\n;;\n"
  453.    ";; Usage instructions:\n;;\n"
  454.    ";; Known bugs:\n;;\n"
  455.    (format
  456.     ";; LCD Archive Entry:\n;; %s|%s|%s@%s\n;; |%s\n;; %s|%s||\n;;\n"
  457.     name
  458.     (user-full-name)
  459.     (user-login-name) (system-name)
  460.     description
  461.     (current-time-string)
  462.     version)))
  463.  
  464. (defun submit-lcd-entry (name)
  465.   "Submit code for the LCD archive.  Prompts for package name, version, and  a
  466. one-line description of the package.  Leaves you in a mail buffer."
  467.   (interactive "sPackage name: ")
  468.   (require 'sendmail)
  469.   (mail nil elisp-submission-address name)
  470.   (message (substitute-command-keys "Type \\[mail-send] to send bug report.")))
  471.  
  472. (provide 'lispdir)
  473.