home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / maintain-lcd.el < prev    next >
Encoding:
Text File  |  1992-03-23  |  32.5 KB  |  924 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;; maintain-lcd.el -- Useful functions for LCD maintaince work
  3. ;; RCSID           : $Header$
  4. ;; Author          : David Brennan (brennan@hal.com)
  5. ;; Created On      : Sat Dec 15 16:31:41 1990
  6. ;; Last Modified By: Dave Brennan
  7. ;; Last Modified On: Mon Mar 23 23:35:32 1992
  8. ;; Update Count    : 84
  9. ;; Status          : Works...mostly.
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;; LCD Archive Entry:
  13. ;; maintain-lcd|David Brennan|brennan@hal.com
  14. ;; |Useful functions for LCD maintaince work
  15. ;; |92-03-23|2.13|~/misc/maintain-lcd.el.Z|
  16.  
  17. ;;
  18. ;; Generally all you need to use is M-x lcd-process-buffer.
  19.  
  20. ;; You may need to refill some paragraphs in beginning of mail messages
  21. ;; before finalizing the entry.
  22.  
  23. ;; Recent Changes:
  24.  
  25. ;; Wed Jul 24, 1991 (DJB)
  26. ;;
  27. ;; * Added parsing and handling of "LCD Archive Entry" info provided in
  28. ;;   files being procedded.  There may be problems with strangely or
  29. ;;   incorrectly formatted entries, but the format is rather flexible as
  30. ;;   suggested by Joe Wells.
  31. ;; * Give archiver a chance to add "LCD Archive Entry" to buffers before
  32. ;;   archiving if one doesn't exist.  If one does it is updated with the
  33. ;;   entry in the "*LCD Entry*" buffer and the archived is ask to OK it.
  34.  
  35. ;; Tue June 4, 1991 (DJB)
  36. ;;
  37. ;; * Added ability to archive from a buffer not visiting a file
  38. ;;   (like a GNUS *Article* buffer!) or a read-only buffer
  39. ;; * Improved ability to process files on a remote host
  40. ;; * lcd-guess-date won't fail with ange-ftp if the date can't be
  41. ;;   parsed out of the article.
  42. ;; * Improved lcd-guess-name and lcd-guess-file-name heuristics
  43. ;;   by searching buffer for possible package names
  44. ;; * Added lcd comment regions, because lcd-comment-header often
  45. ;;   stops prematurely
  46. ;; * Added lcd-shadow-directory variable - its setting determines where or
  47. ;;   if archived files are shadowed locally
  48.  
  49.  
  50. ;; Check out the variables below for customizations.
  51.  
  52. ;; TODO:
  53. ;;
  54. ;; * If item being archived is last entry in LCD-changes don't
  55. ;;   ask replacement question, and don't add replace LCD-changes
  56. ;;   entry instead of adding a new entry.
  57. ;; * Sometimes shar files contain multiple lisp files, but only on
  58. ;;   lisp file can contain the "LCD Archive Entry"  Maybe add some
  59. ;;   way to indicate in the entry that it is only part of a package
  60. ;;   so that people don't get ahold of the single file and not realize
  61. ;;   that something is missing.
  62. ;; * don't comment out headers if file contains .sh or .shar suffix
  63. ;;   (or maybe use a '#' comment)  (Can be done with pfx arg currently)
  64. ;; * some code to add an entry (with duplicate verifcation) without
  65. ;;   a corresponding file
  66. ;; * a nicer interface for editing lcd entries??
  67. ;; * some kind of save hook on the LCD-datafile so it isn't sorted for
  68. ;;   each addition (since it is sloooow)
  69. ;; * is there any kind of nice way to get the create date of a remove file
  70. ;;   with ange-ftp?  file-attributes seems useless
  71.  
  72. (require 'lispdir)
  73. (require 'ange-ftp)
  74. (require 'crypt)     ;; Expects Kyle Jones' crypt.el
  75.  
  76. (define-key emacs-lisp-mode-map "\C-c\C-p" 'lcd-process-buffer)
  77.  
  78. (defvar lcd-insert-marker-key "\C-cm"
  79.   "Key temporarily bound to lcd-insert-formatted-entry in lcd-finalize-entry
  80. if a marker isn't present in the lcd-working-buffer.  Look at the code below
  81. or try it if this isn't clear.")
  82.  
  83. (defvar lcd-header-max 1000
  84.   "Number of characters at the start of a buffer that will be
  85. searched by the lcd-* functions for information.")
  86.  
  87. (defvar lcd-month-alist
  88.   '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
  89.     ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" .10) ("Nov" .11) ("Dec" .12))
  90.   "Association list of month strings and their month number.")
  91.  
  92. (defconst lcd-date-format "%02d-%02d-%02d"
  93.   "Format string for LCD dates.  The order of arguments is currently fixed
  94. at year, month, day, and are integers.")
  95.  
  96. (defvar lcd-archive-directories
  97.   '("as-is" "epoch" "functions" "games" "interfaces" "misc" "modes"
  98.     "packages" "terms" "patches")
  99. "List of directories in the LCD archive.  They are used for completion
  100. when an archive directory name is needed.")
  101.  
  102. (defconst lcd-suffixes-regexp "\\.el$\\|\\.el\\.Z$"
  103.  "Regexp of suffixes to strip from filnames when generating the package name.")
  104.  
  105. (defconst lcd-useless-headers-regexp
  106.   "^From \\|^Article \\|^Message-ID: \\|^Sender: \\|^Distribution: \\|^Lines: \\|^CC: \\|^Posted-Date: \\|^To: \\|^Originator: \\|^Xref:"
  107. "Regexp of headers that don't need to be kept in archived files.")
  108.  
  109. (defconst lcd-name-regexp
  110.   "\\([a-zA-Z0-9_-]+\\)\\.el"
  111.   "Regexp for matching possible package names.  \1 should be the name without
  112. any suffix.")
  113.  
  114. (defvar lcd-target-buffer nil
  115.   "*Buffer in which lcd-generate-and-insert-entry will insert an LCD entry.")
  116.  
  117. (defconst lcd-entry-edit-buffer "*LCD Entry*"
  118.   "Buffer used for displaying and editing new LCD entries.")
  119.  
  120. (defconst lcd-archive-file-buffer "*LCD Archive File*"
  121.   "Buffer used to process buffers which are read-only.")
  122.  
  123. (defvar lcd-archive-path
  124.   "/brennan@python.cis.ohio-state.edu:"
  125.   "*Path identifing the Emacs lisp archive.")
  126.  
  127. (defvar lcd-working-directory "/brennan@python.cis.ohio-state.edu:"
  128.   "*Directory prefix of the local LCD maintain files.")
  129.  
  130. (defvar lcd-shadow-directory nil
  131.   "*Directory prefix of the local archive shadow.  If nil working files
  132. will be temporarily written in lcd-temp-directory.")
  133.  
  134. (defvar lcd-temp-directory "/tmp/"
  135.   "*Directory to which temporary files are written.")
  136.  
  137. (defvar lcd-datafile (concat lcd-working-directory "LCD-datafile.Z")
  138.   "*LCD datafile used by maintain functions.")
  139.  
  140. (defvar lcd-update-file (concat lcd-working-directory "LCD-changes")
  141.   "*Name of the file used to record LCD updates.")
  142.  
  143. (defconst lcd-entry-marker "^\\(.*\\)LCD Archive Entry:[ \t]*"
  144.   "Regexp marker tag for archive entry in archived code. \1 should be the
  145. comment leader after the search.")
  146.  
  147. (defvar lcd-entry-marker-pos nil
  148.   "Marker set to before the next LCD field in the buffer of the file being
  149. archived.")
  150.  
  151. (defconst lcd-entry-text "LCD Archive Entry:"
  152.   "Text version (ie: no regexp stuff) of lcd-entry marker")
  153.  
  154. (defconst lcd-update-marker "---- next updated entry ----"
  155.   "String in lcd-update-file at which entries changed in lcd-datafile will
  156. be listed.")
  157.  
  158. (defconst lcd-new-marker "---- next new entry ----"
  159.   "String in lcd-update-file at which entries added to lcd-datafile will
  160. be listed.")
  161.  
  162. (defvar lcd-raw-apropos-buffer "*LCD Raw Apropos*"
  163.   "*Buffer in which lcd-raw-apropos will place it's output.")
  164.  
  165. (defvar lcd-keep-buffers nil
  166.   "*Set to non-nil to keep working file and lcd temporary buffers after
  167. an entry is finalized.  If nil they will all be killed on finalize.
  168. The lcd-datafile and lcd-update-file buffers will never be killed.")
  169.  
  170. (defvar lcd-working-buffer nil
  171.   "The buffer currently being worked on.")
  172.  
  173. (defvar lcd-working-file nil
  174.   "File visited by buffer lcd-process-buffer is run in.")
  175.  
  176. (defvar lcd-last-entry ""
  177.   "String containing the last lcd entry generated.")
  178.  
  179. (defvar lcd-saved-window-configuration nil
  180.   "Window configuration when lcd-process-buffer is called.  Used to restore
  181. the window configuration after lcd-finalize-entry is run.")
  182.  
  183. (defvar lcd-format-function 'lcd-format-for-mail
  184.   "Function used by lcd-format-region to format raw LCD entries.")
  185.  
  186. (defvar lcd-mail-intro
  187. "Here is the lisp formatted LCD (Lisp Code Directory) entry and archive path
  188. for the code which has been added to the Emacs lisp archive on
  189. archive.cis.ohio-state.edu:
  190. "
  191. "Introduction for mail message to author of E-lisp code.")
  192.  
  193. (defvar lcd-mail-closing
  194. "You will make the job of the archive maintainers easier if you include the
  195. above entry in future revisions of your code.  Also, you can help users
  196. distinguish between different version of your code by providing a version
  197. string in the entry if you do not already do so.  For more information,
  198. please see the file \"guidelines\" in the elisp-archive directory on archive.
  199. I can mail you a copy if you cannot ftp.
  200.  
  201. Finally, if you have a more up-to-date version of this code or have any
  202. corrections for the entry please let me know.  If there are no changes now
  203. I'd appreciate being notified of future revisions.
  204.  
  205. Thanks,"
  206.   "Closing for mail message to author of E-lisp code.")
  207.  
  208. ;;;
  209. ;;; End of variables section
  210. ;;;
  211.  
  212. (defun match-substring (&optional count)
  213.   "Return the text matched by the last regexp search.  Optional ARG, a
  214. number, specifies that the ARGth parenthesized expression should be
  215. returned.  If ARG is missing or zero the entire text matched is returned.
  216. If there are less than ARG expressions nil is returned."
  217.   (if (not count)
  218.       (setq count 0))
  219.   (buffer-substring (match-beginning count) (match-end count)))
  220.  
  221. (defun lcd-generate-names ()
  222.   "Returns a list of possible names for elisp in the current buffer.
  223. The cdr of each list element is the number of times it appeared in
  224. the buffer.  The list is sorted from most frequent occurrence to
  225. least frequent.  Elements which occured the same number of times
  226. are in order of occurence."
  227.   (save-excursion
  228.     (goto-char 1)
  229.     (let (names)
  230.       (while
  231.       (re-search-forward lcd-name-regexp nil t)
  232.     (let* ((name (match-substring 1))
  233.           (element (assoc name names)))
  234.       (if element
  235.           (setcdr element (1+ (cdr element)))
  236.         (setq names (cons (cons name 1) names)))))
  237.       ;; do a special search for "provide" with special weighting
  238.       (goto-char 1)
  239.       (if (re-search-forward "(provide '\\([a-zA-Z0-9_-]+\\))" nil t)
  240.       (let* ((name (match-substring 1))
  241.          (element (assoc name names)))
  242.         (if element
  243.         (setcdr element (+ 1000 (cdr element)))
  244.           (setq names (cons (cons name 1000) names)))))
  245.       ;; reverse list to occurence order
  246.       (setq names (nreverse names))
  247.       ;; sort by number of occurrences
  248.       (sort names '(lambda (el1 el2) (> (cdr el1) (cdr el2)))))))
  249.  
  250.  
  251. (defun lcd-get-next-field ()
  252.   "Get the next author provided field in the region indicated by the
  253. lcd-entry-marker regexp."
  254.   (if lcd-entry-marker-pos
  255.       (save-excursion
  256.     (goto-char lcd-entry-marker-pos)
  257.     ;; grab from point to next '|' or end of line and move pos forward
  258.     (if (re-search-forward "[^|\n]*" nil t)
  259.         (progn
  260.           (if (= (char-after (point)) ?|)
  261.           (forward-char 1))
  262.           (setq lcd-entry-marker-pos (point))
  263.           (if (string-equal (match-substring 0) "")
  264.           nil
  265.         (match-substring 0)))))))
  266.  
  267.  
  268. (defun lcd-guess-name ()
  269.   "Try to figure out the package name of the current buffer.  Base guess
  270. on number of occurences of lcd-name-regexp in buffer and the name of the
  271. file.  If the name of the file without suffixes matches one of the names
  272. from lcd-generate-names it is used, and no prompting is done.  Otherwise
  273. the user is prompted for a name with completing-read, using the list from
  274. lcd-generate-names.  The first name in the list is used as the default
  275. response."
  276.   (or (lcd-get-next-field)
  277.       (let* ((name (lcd-guess-file-name))
  278.          (pos (string-match lcd-suffixes-regexp name))
  279.          (name (if pos (substring name 0 pos) name))
  280.          (names (lcd-generate-names))
  281.          (match (assoc name names)))
  282.     (if match
  283.         (car match)
  284.       (let* ((default (car (car names)))
  285.          (pick (completing-read
  286.             (if default
  287.                 (format "Package name [%s]: " default)
  288.               "Package name: ")
  289.             names)))
  290.         (if (equal pick "")
  291.         default
  292.           pick))))))
  293.  
  294.  
  295. (defun lcd-guess-author ()
  296.   "Try to figure out the name of the author of the elisp in the current buffer.
  297. Currently this function only knows about mail \"From:\" headers."
  298.   (or (lcd-get-next-field)
  299.       (save-excursion
  300.     (goto-char 1)
  301.     (cond
  302.      ;; for address of the form "contact@foobar (Author's Name)"
  303.      ((re-search-forward "From:.*(\\(.*\\))" lcd-header-max t)
  304.       (match-substring 1))
  305.      ;; for address of the form "Author's Name <contact@foobar>"
  306.      ((re-search-forward "From: \\(.*\\) <.*>" lcd-header-max t)
  307.       (match-substring 1))
  308.      ;; for non-parsable addresses
  309.      (t "")))))
  310.  
  311. (defun lcd-guess-contact ()
  312.   "Try to figure out the email address of the author of the elisp in the
  313. current buffer.  Currently this function only knows about mail \"From:\"
  314. headers."
  315.   (or (lcd-get-next-field)
  316.       (save-excursion
  317.     (goto-char 1)
  318.     (cond
  319.      ;; for address of the form "contact@foobar (Author's Name)"
  320.      ((re-search-forward ";? ?From: \\(.*\\) (.*)" lcd-header-max t)
  321.       (match-substring 1))
  322.      ;; for addresses of the form "Author's Name <contact@foobar>"
  323.      ((re-search-forward "From: .* <\\(.*\\)>" lcd-header-max t)
  324.       (match-substring 1))
  325.      (t "")))))
  326.  
  327. (defun lcd-uncompressed-file-name ()
  328.   "Return the file name of the current buffer without the \".Z\" suffix,
  329. if present."
  330.   (let* ((name (lcd-guess-file-name))
  331.     (pos (string-match "\\.Z$" name)))
  332.     (if pos
  333.     (substring name 0 pos)
  334.       name)))
  335.  
  336. (defun lcd-guess-description ()
  337.   "Try to figure out a description string for the elisp in the current buffer.
  338. The following strategies are used:
  339.  
  340.  * Search for \"name -- <description>\"
  341.  * Search for \"Description: <description>\"
  342. "
  343.   (or (lcd-get-next-field)
  344.       (save-excursion
  345.     (goto-char 1)
  346.     (cond
  347.      ((re-search-forward (concat ";;;? "
  348.                     (regexp-quote (lcd-uncompressed-file-name))
  349.                     " ---? \\(.*\\)")
  350.                  (point-max) t)
  351.       (match-substring 1))
  352.      ((re-search-forward "Description:[ \t]*\\(.*\\)" (point-max) t)
  353.       (match-substring 1))
  354.      ( t "")))))
  355.  
  356. (defun lcd-guess-date ()
  357.   "Try to figure out the mailed or last changed date of the elisp in the
  358. current buffer.  This function first looks for a \"Date:\" header, then
  359. the creation date of the file, if available."
  360.   (or (lcd-get-next-field)
  361.       (save-excursion
  362.     (goto-char 1)
  363.     (cond
  364.      ((re-search-forward
  365.        "Date: \\([A-Z][a-z][a-z], \\)?\\([0-9][0-9]?\\) \\([A-Z][a-z][a-z]\\) \\([0-9][0-9]\\)"
  366.        lcd-header-max t)
  367.       (format lcd-date-format
  368.           (string-to-int (match-substring 4))                ; year
  369.           (cdr (assoc (match-substring 3) lcd-month-alist))  ; month
  370.           (string-to-int (match-substring 2))                ; day
  371.           ))
  372.      
  373.      ;; only try this on the local system - won't work with ange-ftp
  374.      ((not (string-match (car ange-ftp-path-format)
  375.                  (buffer-file-name)))
  376.       (let ((file-name (buffer-file-name)))
  377.         (set-buffer (get-buffer-create " *LCD Capture Date*"))
  378.         (erase-buffer)
  379.         (shell-command (concat "sls -p '%c\"%y-%m-%d\"' " file-name) t)
  380.         (setq result (buffer-substring (point) (- (mark) 1)))
  381.         (kill-buffer (current-buffer))
  382.         result))
  383.      (t "")))))
  384.  
  385. (defun lcd-guess-version ()
  386.   "Try to figure out a version string for the elisp in the current buffer.
  387. Currently this functions returns an empty string."
  388.   (or (lcd-get-next-field)
  389.       ""))
  390.  
  391. (defun lcd-guess-file-name ()
  392.   "Try to figure out the file name of the elisp in the current buffer.
  393. This function assumes the file name of the buffer with a \".Z\"
  394. appended if necessary.  If the buffer is not associated with a file
  395. the package name will be used if this function was called from
  396. lcd-build-entry."
  397.   (let ((full-name (buffer-file-name)))
  398.     (if full-name
  399.     (file-name-nondirectory
  400.      (if (string-match "\\.Z$" full-name)
  401.          full-name
  402.        (concat full-name ".Z")))
  403.       ;; name is set in lcd-build-entry
  404.       (if (boundp 'name)
  405.       (concat name ".el.Z")
  406.     ""))))
  407.  
  408. (defun lcd-guess-archive ()
  409.   "Try to guess the archive name of the elisp in the current buffer."
  410.   (or (lcd-get-next-field)
  411.       (concat
  412.        "~/"
  413.        (completing-read "Classification: "
  414.             (mapcar 'list lcd-archive-directories))
  415.        "/"
  416.        (lcd-guess-file-name))))
  417.  
  418. (defun lcd-one-lineify ()
  419.   "Make the LCD entry in the current buffer one line.  Returns nil if the
  420. buffer does not contain an entry, the comment leader otherwise.  Leaves
  421. the point at the start of the line containing the entry."
  422.   (let (leader old-syntax (end-marker (make-marker)))
  423.   (goto-char 1)
  424.   (if (re-search-forward lcd-entry-marker nil t)
  425.       (progn
  426.     (setq leader (match-substring 1))
  427.     ;; go to start of next line if the rest of this one is blank
  428.     (if (looking-at "\n")
  429.         (goto-char (match-end 0))
  430.       (insert ?\n))
  431.     (setq old-syntax (char-to-string (char-syntax ?|)))
  432.     (modify-syntax-entry ?| "w")
  433.     (insert ?\n)
  434.     ;; get rid of comments and concat lines
  435.     ;; Find the next line after the 7th "|" or the first
  436.     ;; line with a different leader - whichever comes first.
  437.     (save-excursion
  438.       (while (looking-at "^;; .")
  439.         (forward-line 1))
  440.       (set-marker end-marker (point)))
  441.     (save-excursion
  442.       (if (search-forward "|" nil 'no-error 7)
  443.           (progn
  444.         (forward-line 1)
  445.         (beginning-of-line)
  446.         (if (< (point) (marker-position end-marker))
  447.             (set-marker end-marker (point))))))
  448.     (while (re-search-forward (concat "^" leader "\\<") end-marker t)
  449.       ;; delete comment leader and merge with previous line
  450.       (delete-region (1- (match-beginning 0)) (match-end 0))
  451.       (forward-line 1))
  452.     (forward-line -1)
  453.     (modify-syntax-entry ?| old-syntax)
  454.     (insert leader)
  455.     leader))))
  456.  
  457. (defun lcd-build-entry ()
  458.   "Generate an LCD datafile entry for the current buffer, filling in as
  459. many fields as possible.  The format this function generates is
  460. Name|Author|Contact (Email)|Description|Date|Version|Archive."
  461.  
  462.   ;; Look for author supplied entry and set position and comment leader
  463.   ;; if found.
  464.   (setq lcd-entry-marker-pos (if (lcd-one-lineify) (point)))
  465.       
  466.   (let* ((name         (lcd-guess-name))
  467.      (author       (lcd-guess-author))
  468.      (contact      (lcd-guess-contact))
  469.      (description  (lcd-guess-description))
  470.      (date         (lcd-guess-date))
  471.      (version      (lcd-guess-version))
  472.      (archive      (lcd-guess-archive)))
  473.     (format "%s|%s|%s|%s|%s|%s|%s"
  474.         name
  475.         author
  476.         contact
  477.         description
  478.         date
  479.         version
  480.         archive)))
  481.  
  482. (defun lcd-generate-and-insert-entry ()
  483.   "Generate a best guess LCD datafile entry for the current buffer, and
  484. insert it in the buffer lcd-target-buffer.  The entry is inserted at the
  485. current line if it is empty, or after the current line if it contains text."
  486.   (interactive)
  487.   (let ((lcd-entry (lcd-build-entry)))
  488.     (progn
  489.       (set-buffer lcd-target-buffer)
  490.       ;; if the point is not at the start of a blank line make a new line
  491.       (if (not (and (= (current-column) 0)
  492.             (or (= (following-char) ?\n) (= (following-char) 0))))
  493.       (progn (end-of-line) (insert ?\n)))
  494.       (insert lcd-entry)
  495.       (if (get-buffer-window lcd-target-buffer)
  496.       (set-window-point (get-buffer-window lcd-target-buffer) (point))
  497.     ))))
  498.  
  499. (defun lcd-raw-apropos (topic)
  500.   "Find raw lisp code directory entries in lcd-file matching TOPIC."
  501.   (interactive (list
  502.         (read-string
  503.          (concat "Raw apropos (" (current-word) "): "))))
  504.   (if (equal "" topic) (setq topic (current-word)))
  505.   (save-excursion
  506.     (set-buffer (get-buffer-create lcd-raw-apropos-buffer))
  507.     (fundamental-mode)
  508.     (setq buffer-read-only nil)
  509.     (erase-buffer)
  510.     (buffer-flush-undo (current-buffer))
  511.     (lisp-dir-insert-datafile)
  512.     (delete-non-matching-lines topic)
  513.     (set-buffer-modified-p nil)
  514.     (setq buffer-read-only t))
  515.   (display-buffer lcd-raw-apropos-buffer))
  516.  
  517. (defun lcd-comment-header ()
  518.   "Comment out any header information in a Emacs lisp file."
  519.   (save-excursion
  520.     (goto-char (point-min))
  521.     (while (not (looking-at "^[ \t]*\\(;\\|(\\)"))
  522.       (insert-string "; ")
  523.       (forward-line 1)
  524.       (beginning-of-line))))
  525.  
  526. (defun lcd-comment-region (start end)
  527.   "Comment out the region with \"; \".  Called from a program takes
  528. arguments START and END."
  529.   (interactive "r")
  530.   (let ((end-marker (make-marker)))
  531.     (set-marker end-marker end)
  532.     (goto-char start)
  533.     (beginning-of-line)
  534.     (insert-before-markers "; ")
  535.     (while (search-forward "\n" (marker-position end-marker) 1)
  536.       (insert-before-markers "; "))))
  537.  
  538. (defun lcd-prune-headers ()
  539.   "Remove lines between the beginning of the buffer and lcd-header-max
  540. that match lcd-useless-headers-regexp."
  541.   (save-excursion
  542.     (goto-char (point-min))
  543.     (while (re-search-forward lcd-useless-headers-regexp lcd-header-max t)
  544.       (beginning-of-line)
  545.       (kill-line 1))))
  546.  
  547. ;; this really should be interactive (data available in lcd-last-entry)
  548.  
  549. (defun lcd-mail-author (author package)
  550.   (let ((saved-mail-archive-file-name mail-archive-file-name)
  551.     (region-start))
  552.     ;; Don't want message "FCC"ed to some file...
  553.     (setq mail-archive-file-name nil)
  554.     (mail nil author (concat "Your E-lisp code (" package
  555.                  ") has been added to the archive."
  556.     "\nFrom: elisp-archive@cis.ohio-state.edu (Elisp Archive Maintainer)"))
  557.     (end-of-buffer)
  558.     (insert lcd-mail-intro "\n")
  559.     (setq region-start (point))
  560.     (insert lcd-last-entry)
  561.     (lcd-format-region region-start (point))
  562.     (insert "\n\n" lcd-mail-closing "\n")
  563.     ;; (mail-signature)
  564.     (setq mail-archive-file-name saved-mail-archive-file-name)))
  565.  
  566. (defun lcd-log-entry (name-and-author entry)
  567.   "Log the specified entry in the lcd-datafile and the lcd-update-file."
  568.   (let ((entry-marker lcd-new-marker))
  569.     (save-excursion
  570.       ;; look for a duplicate in lcd-datafile
  571.       (set-buffer (find-file-noselect lcd-datafile))
  572.       (goto-char (point-min))
  573.       ;; try the search, if it works ask the question
  574.       ;; if either one fails add it and sort
  575.       (or (if (search-forward name-and-author (point-max) t)
  576.           (save-excursion
  577.         (find-file lcd-datafile)
  578.         (beginning-of-line)
  579.         (set-window-start (selected-window) (point))
  580.         (if (yes-or-no-p "Replace this entry? ")
  581.             (progn
  582.               (setq entry-marker lcd-update-marker)
  583.               (kill-line 1)
  584.               (insert entry)
  585.               t))))
  586.       ;; no match or "no" answer, so just add it and sort
  587.       (save-excursion
  588.         (set-buffer (find-file-noselect lcd-datafile))
  589.         (goto-line 2)
  590.         (insert entry)
  591.         (previous-line 1)
  592.         (sort-lines nil (point) (point-max)))))
  593.     ;; add the entry to the lcd-update-file
  594.     (save-excursion
  595.       (set-buffer (find-file-noselect lcd-update-file))
  596.       (goto-char (point-min))
  597.       (if (search-forward entry-marker (point-max) t)
  598.       (progn
  599.         (beginning-of-line)
  600.         (insert entry))
  601.     (progn
  602.       (message "Couldn't find marker string %s in %s." entry-marker
  603.            (file-name-nondirectory lcd-update-file))
  604.       (sit-for 2))))))
  605.  
  606. ;; this routine needs to update the marker if it already exists!
  607.  
  608. (defun lcd-entry-marker-check ()
  609.   "Check the lcd-working-buffer for an \"LCD Archive Entry:\" marker, asking
  610. user for verification if it isn't there."
  611.   (save-excursion
  612.     (let (result comment)
  613.       (set-buffer lcd-working-buffer)
  614.       (beginning-of-buffer)
  615.       ;; replace it if found
  616.       (if (setq comment (lcd-one-lineify))
  617.       (progn
  618.         (forward-line -1)    ; move back to "LCD Archive Entry" line
  619.         (kill-line 2)
  620.  ;;        (insert ?\n)
  621.         (lcd-insert-formatted-entry comment)
  622.         (set-window-point (display-buffer (current-buffer)) (point))
  623.         (yes-or-no-p "Does this look OK? "))
  624.     ;; else let the user insert
  625.     (let ((saved-binding (key-binding lcd-insert-marker-key)))
  626.       ;; switch binding for a while
  627.       (local-set-key lcd-insert-marker-key 'lcd-insert-formatted-entry)
  628.       (setq result
  629.         (yes-or-no-p
  630.          "No entry marker found (insert with C-c m).  Contunue? "))
  631.       ;; restore previous binding
  632.       (local-set-key lcd-insert-marker-key saved-binding)
  633.       result)))))
  634.  
  635.  
  636. (defun lcd-finalize-entry (arg)
  637.   "Merge the LCD entry in the buffer \"*LCD Entry*\" into lcd-datefile and
  638. make an appropriate entry in lcd-update-file-name."
  639.   (interactive "P")
  640.   (if (lcd-entry-marker-check)
  641.   (progn
  642.   (let (name name-and-author new-file-name contact archive-path)
  643.     (save-excursion
  644.       (set-buffer lcd-entry-edit-buffer)
  645.       (goto-line 2)
  646.       ;; grab some info
  647.       (re-search-forward "^\\(.*\\)|\\(.*\\)|\\(.*\\)|.*|.*|.*|\\(.*\\)")
  648.       (setq lcd-last-entry (concat (match-substring 0) "\n")
  649.         name (match-substring 1)
  650.         name-and-author (concat name "|" (match-substring 2))
  651.         contact (match-substring 3)
  652.         archive-path (match-substring 4))
  653.       (setq new-file-name
  654.         ;; drop file in the shadow directory if specified
  655.         (if lcd-shadow-directory
  656.         (concat lcd-shadow-directory (substring archive-path 2))
  657.           ;; otherwise use a temp file
  658.           (concat lcd-temp-directory "lcd-"
  659.               (file-name-nondirectory archive-path)))))
  660.     
  661.     ;; now log the entry to the appropriate files
  662.     (lcd-log-entry name-and-author lcd-last-entry)
  663.  
  664.     ;; write out the file and move it to the proper place
  665.     (set-buffer lcd-working-buffer)
  666.  
  667.     ;; put buffer in compress mode if it isn't already and should be
  668.     (if (string-match "\\.Z$" new-file-name)
  669.     (compress-mode 1))
  670.  
  671.     ;; finally save it
  672.     ;; (this will probably leave an auto-save file, but that's ok)
  673.     ;; buffer will also now visit the new file
  674.     
  675.     (write-file new-file-name)
  676.     (if (and lcd-working-file (file-readable-p lcd-working-file))
  677.     (delete-file lcd-working-file))
  678.     
  679.     ;; update dired as well
  680.     (if (and lcd-working-file (fboundp 'dired-remove-entry-all-buffers))
  681.     (dired-remove-entry-all-buffers lcd-working-file))
  682.  
  683.     ;; send the file to the archive (this depends on having ange-ftp!)
  684.     ;; confirmation is requsted if the file already exists
  685.  
  686.     ;; this code should probably abort nicely if the user doesn't confirm
  687.     ;; for now it doesn't hurt to abort here
  688.     ;; the confirmation request is usually impossible to read because of
  689.     ;; the line length, so a specific check would be better
  690.     ;; however, the check does slow things down, because we need to do
  691.     ;; an ls of the dir twice, so I'll leave it alone for now
  692.  
  693.     (if lcd-archive-path
  694.     (let ((archive-name (concat lcd-archive-path
  695.                     (substring archive-path 2))))
  696.     (copy-file new-file-name archive-name 1 t)))
  697.  
  698.     ;; if new-file is a temp file delete it, else update dired
  699.     (if (equal lcd-temp-directory (file-name-directory new-file-name))
  700.     (delete-file new-file-name)      
  701.       (if (fboundp 'dired-add-entry-all-buffers)
  702.       (dired-add-entry-all-buffers (file-name-directory new-file-name)
  703.                       (file-name-nondirectory new-file-name))))
  704.  
  705.     ;; make it so dired buffer appears after mail is sent
  706.     ;; this assumes that we were using dired
  707.     (if lcd-working-file
  708.     (set-buffer (find-file-noselect
  709.              (file-name-directory lcd-working-file))))
  710.              
  711.     ;; send mail to the author
  712.     (lcd-mail-author contact name)
  713.  
  714.     ;; finally back to the way things were
  715.     (set-window-configuration lcd-saved-window-configuration)
  716.  
  717.     (if lcd-keep-buffers
  718.     nil
  719.       (kill-buffer lcd-working-buffer)
  720.       (kill-buffer lcd-entry-edit-buffer)
  721.       (kill-buffer lcd-raw-apropos-buffer))))))
  722.  
  723. (defun lcd-process-buffer (&optional arg)
  724.   "Process the current buffer for submission into the Emacs lisp archive
  725. and create and LCD entry for the LCD data file.  Prefix arg means do not
  726. try to comment out the header.  [more docs needed]"
  727.   (interactive "P")
  728.   (setq lcd-saved-window-configuration (current-window-configuration))
  729.   (if (equal "*Subject*" (buffer-name))
  730.       (switch-to-buffer "*Article*"))
  731.   (if (equal "*Article*" (buffer-name))
  732.       (let ((gnus-Article-prepare-hook nil))
  733.     (gnus-Article-show-all-headers)
  734.     (delete-other-windows)))
  735.  
  736.   ;; copy buffer to editable buffer if original is read-only
  737.   
  738.   (if buffer-read-only
  739.       (let ((edit-buffer (get-buffer-create lcd-archive-file-buffer)))
  740.     (save-excursion
  741.       (set-buffer edit-buffer)
  742.       (erase-buffer))
  743.     (save-restriction
  744.       (widen)
  745.       (copy-to-buffer edit-buffer (point-min) (point-max)))
  746.     (buffer-flush-undo edit-buffer)
  747.     (buffer-enable-undo edit-buffer)
  748.     (switch-to-buffer edit-buffer)
  749.     (if buffer-read-only (toggle-read-only))))
  750.  
  751.   ;; go to work on the entry buffer
  752.  
  753.   (let ((entry (lcd-build-entry))
  754.     pattern)
  755.     (lcd-prune-headers)
  756.     (if (not arg)
  757.     (lcd-comment-header))
  758.     (setq lcd-working-file (buffer-file-name)
  759.       lcd-working-buffer (current-buffer))
  760.  
  761.     ;; set up the buffer to edit the new lcd entry
  762.  
  763.     (split-window-vertically 12)
  764.     (switch-to-buffer lcd-entry-edit-buffer)
  765.     (fundamental-mode)
  766.     (local-set-key "\C-c\C-c" 'lcd-finalize-entry)
  767.     (local-set-key "\t" 'lcd-edit-next-field)
  768.     (local-set-key "\e\t" 'lcd-edit-previous-field)
  769.     (modify-syntax-entry ?| " ")
  770.     (erase-buffer)
  771.     (buffer-flush-undo (current-buffer))
  772.     (buffer-enable-undo (current-buffer))
  773.     (insert
  774.      "Name | Author | Contact | Description | Date | Version | Archive\n"
  775.      entry)
  776.  
  777.     ;; get the first two elements of ENTRY and search for them in current LCD
  778.  
  779.     (beginning-of-line)
  780.     (re-search-forward "^[^|]*")   ; can't fail
  781.     (setq pattern (match-substring 0))
  782.     (if (equal pattern "")
  783.     (setq pattern nil))
  784.     (forward-char 1)            ; skip over '|'
  785.     (re-search-forward "[^|]*")
  786.     ;; if there's no author name, leave it out
  787.     (if (not (equal (match-substring 0) ""))
  788.     (setq pattern (concat pattern (if pattern "\\|") (match-substring 0))))
  789.     (beginning-of-line)
  790.  
  791.     ;; display any matches in another window
  792.     ;; this helps the user avoid duplicat names
  793.  
  794.     (split-window-vertically 5)
  795.     (if pattern
  796.     (lcd-raw-apropos pattern))
  797.     (beginning-of-line)
  798.     (message "Edit lisp file and/or LCD entry.  Press C-c C-c when done.")
  799.     ))
  800.  
  801. (defun lcd-edit-next-field ()
  802.   "Goto the start of the next field in the lcd edit buffer."
  803.   (interactive)
  804.   (search-forward "|" nil 'goto-end))
  805.  
  806. (defun lcd-edit-previous-field ()
  807.   "Goto the start of the next field in the lcd edit buffer."
  808.   (interactive)
  809.   (backward-char 1)
  810.   (if (re-search-backward "|\\|\n" nil 'goto-start)
  811.       (forward-char 1)))
  812.  
  813. (defun lcd-format-region (start end)
  814.   "Format all LCD entries in region to a human readable format.  When used
  815. from a program the arguments START and END are required.  Adapted to work
  816. on non-empty starting buffers."
  817.   (interactive "r")
  818.   (save-restriction
  819.     (narrow-to-region start end)
  820.     (goto-char start)
  821.     (beginning-of-line)
  822.     (while (re-search-forward
  823.        "\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)|\\(.*\\)" nil t)
  824.       (let ((name (match-substring 1))
  825.         (author (match-substring 2))
  826.         (contact (match-substring 3))
  827.         (description (match-substring 4))
  828.         (date (match-substring 5))
  829.         (version (match-substring 6))
  830.         (archive (match-substring 7)))
  831.     (delete-region
  832.      (progn (beginning-of-line) (point))
  833.      (progn (end-of-line) (point)))
  834.     (funcall lcd-format-function
  835.          name author contact description date version archive)))))
  836.  
  837. (defun lcd-insert-formatted-entry (&optional comment-leader)
  838.   "Insert at the point the formatted version of the LCD entry in
  839. the lcd-entry-edit-buffer."
  840.   (interactive)
  841.   (let ((lcd-format-function 'lcd-format-for-lisp-code)
  842.     entry start)
  843.     (save-excursion
  844.       (set-buffer lcd-entry-edit-buffer)
  845.       (goto-line 2)
  846.       (setq start (point))
  847.       (end-of-line)
  848.       (setq entry (concat (buffer-substring start (point)) "\n")))
  849.     (beginning-of-line)
  850.     (setq start (point))
  851.     (insert entry)
  852.     (lcd-format-region start (point))))
  853.  
  854. (defun lcd-format-for-change-buf (start end)
  855.   "Format all LCD entires in the region using the lcd-format-lcd-line
  856. function.  This will move to where the change entry actually gets done.
  857. This function exists for manual testing."
  858.   (interactive "r")
  859.   (let ((lcd-format-function 'lcd-format-lcd-line))
  860.     (lcd-format-region start end)))
  861.  
  862. (defun lcd-format-lcd-line
  863.   (name author contact description date version archive)
  864.   "Multi-line non-columnar line formatter for LCD maintainer.
  865. Adapted from Dave Sill's version."
  866.   (insert-at-column 0 name)
  867.   (if (not (equal version ""))
  868.       (insert "  (Version " version ")")
  869.     (insert "  (version unknown)"))
  870.   (insert "  " date)
  871.   (insert "\n")
  872.   (if (and (string-match "[0-9]+\.[0-9]+ dist" contact)
  873.        (equal author "FSF"))
  874.       (insert-at-column 2 contact)
  875.     (progn
  876.       (insert-at-column 2 author)
  877.       (insert ", <" contact ">\n")
  878.       (if (not (equal archive ""))
  879.       (progn
  880.         (if (string-match "~" archive)
  881.         (setq archive (concat "Archived in: " elisp-archive-directory
  882.                       (substring archive 2))))
  883.         (insert-at-column 2 archive)))))
  884.   (insert-at-column 2 description))
  885.  
  886. (defun lcd-build-entry-for-lisp-code
  887.   (prefix name author contact description date version archive)
  888.   "Formatter for entry suitable for inclusion in an Emacs lisp source
  889. code file."
  890.   (concat 
  891.    prefix lcd-entry-text "\n"
  892.    prefix name "|" author "|" contact "|" "\n"
  893.    prefix description "|" "\n"
  894.    prefix date "|"
  895.    (if version version "(no version)") "|" archive "|"))
  896.   
  897. (defun lcd-format-for-mail
  898.   (name author contact description date version archive)
  899.   "Formatter for entry suitable for inclusion in mail to the author
  900. of the code."
  901.   (insert (lcd-build-entry-for-lisp-code
  902.        ";; " name author contact description date version archive))
  903.   (if (not (equal archive ""))
  904.       (progn
  905.     (if (string-match "~" archive)
  906.         (insert (concat "\n\nArchived in: " elisp-archive-directory
  907.                 (substring archive 2)) ?\n)))))
  908.  
  909. (defun lcd-format-for-lisp-code
  910.   (name author contact description date version archive)
  911.   "Formatter for entry suitable for inclusion in an Emacs lisp source
  912. code file."
  913.   (insert (lcd-build-entry-for-lisp-code
  914.        (if (and (boundp 'comment-leader) comment-leader)
  915.            comment-leader ";; ")
  916.        name author contact description date version archive)))
  917.  
  918. (provide 'maintain-lcd)
  919.  
  920. ;; Local Variables:
  921. ;; kept-old-versions: 0
  922. ;; kept-new-versions: 4
  923. ;; End:
  924.