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