# HG changeset patch # User Eric S. Raymond # Date 712215109 0 # Node ID 6dc5b7273a07be25a9e01a924c868cc31cc0cddd # Parent 5b1c5b4286e7ab4b0b2cf9fb1bd3a5eef2b60877 entered into RCS diff -r 5b1c5b4286e7 -r 6dc5b7273a07 lisp/emacs-lisp/lisp-mnt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/lisp-mnt.el Mon Jul 27 05:31:49 1992 +0000 @@ -0,0 +1,423 @@ +;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; Author: Eric S. Raymond +;; Maintainer: Eric S. Raymond +;; Created: 14 Jul 1992 +;; Version: 1.2 +;; Keywords: docs +;; Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out! + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This minor mode adds some services to Emacs-Lisp editing mode. +;; +;; First, it knows about the header conventions for library packages. +;; One entry point supports generating synopses from a library directory. +;; Another can be used to check for missing headers in library files. +;; +;; Another entry point automatically addresses bug mail to a package's +;; maintainer or author. + +;; This file can be loaded by your lisp-mode-hook. Have it (require 'lisp-mnt) + +;; This file is an example of the header conventions. Note the following +;; features: +;; +;; * Header line --- makes it possible to extract a one-line summary of +;; the package's uses automatically for use in library synopses, KWIC +;; indexes and the like. +;; +;; Format is three semicolons, followed by the filename, followed by +;; three dashes, followed by the summary. All fields space-separated. +;; +;; * Author line --- contains the name and net address of at least +;; the principal author. +;; +;; If there are multible authors, they should be listed on continuation +;; lines led by ;;, like this: +;; +;; ;; Author: Ashwin Ram +;; ;; Dave Sill +;; ;; David Lawrence +;; ;; Noah Friedman +;; ;; Joe Wells +;; ;; Dave Brennan +;; ;; Eric Raymond +;; +;; This field may have some special values; notably "FSF", meaning +;; "Free Software Foundation". +;; +;; * Maintainer line --- should be a single name/address as in the Author +;; line, or an address only, or the string "FSF". If there is no maintainer +;; line, the person(s) in the Author field are presumed to be it. The example +;; in this file is mildly bogus because the maintainer line is redundant. +;; The idea behind these two fields is to be able to write a lisp function +;; that does "send mail to the author" without having to mine the name out by +;; hand. Please be careful about surrounding the network address with <> if +;; there's also a name in the field. +;; +;; * Created line --- optional, gives the original creation date of the +;; file. For historical interest, basically. +;; +;; * Version line --- intended to give the reader a clue if they're looking +;; at a different version of the file than the one they're accustomed to. Not +;; needed if you have an RCS or SCCS header. +;; +;; * Adapted-By line --- this is for FSF's internal use. The person named +;; in this field was the one responsible for installing and adapting the +;; package for the distribution. (This file doesn't have one because the +;; author *is* one of the maintainers.) +;; +;; * Keywords line --- used by the finder code (now under construction) +;; for finding elisp code related to a topic. +;; +;; * Bogus-Bureaucratic-Cruft line --- this is a joke. I figured I should +;; satirize this design before someone else did. Also, it illustrates the +;; possibility that other headers may be added in the future for new purposes. +;; +;; * Commentary line --- enables lisp code to find the developer's and +;; maintainers' explanations of the package internals. +;; +;; * Change log line --- optional, exists to terminate the commentary +;; section and start a change-log part, if one exists. +;; +;; * Code line --- exists so elisp can know where commentary and/or +;; change-log sections end. +;; +;; * Footer line --- marks end-of-file so it can be distinguished from +;; an expanded formfeed or the results of truncation. + +;;; Change Log: + +;; Tue Jul 14 23:44:17 1992 ESR +;; * Created. + +;;; Code: + +(require 'picture) ; provides move-to-column-force + +;; These functions all parse the headers of the current buffer + +(defun lm-section-mark (hd) + ;; Return the buffer location of a given section start marker + (save-excursion + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (re-search-forward (concat "^;;; " hd ":$") nil t) + (progn + (beginning-of-line) + (point)) + nil)))) + +(defun lm-code-mark () + ;; Return the buffer location of the code start marker + (lm-section-mark "Code")) + +(defun lm-header (hd) + ;; Return the contents of a named header + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward + (concat "^;; " hd ": \\(.*\\)") (lm-code-mark) t) + (buffer-substring (match-beginning 1) (match-end 1)) + nil))) + +(defun lm-header-multiline (hd) + ;; Return the contents of a named header, with possible continuation lines. + ;; Note -- the returned value is a list of strings, one per line. + (save-excursion + (goto-char (point-min)) + (let ((res (save-excursion (lm-header hd)))) + (if res + (progn + (forward-line 1) + (setq res (list res)) + (while (looking-at "^;;\t\\(.*\\)") + (setq res (cons (buffer-substring + (match-beginning 1) + (match-end 1)) + res)) + (forward-line 1)) + )) + res))) + +;; These give us smart access to the header fields and commentary + +(defun lm-summary (&optional file) + ;; Return the buffer's or FILE's one-line summary. + (save-excursion + (if file + (find-file file)) + (goto-char (point-min)) + (prog1 + (if (looking-at "^;;; [^ ]+ --- \\(.*\\)") + (buffer-substring (match-beginning 1) (match-end 1))) + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-authors (&optional file) + ;; Return the buffer's or FILE's author list. + (save-excursion + (if file + (find-file file)) + (prog1 + (lm-header-multiline "author") + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-maintainer (&optional file) + ;; Get a package's bug-report & maintenance address. Parse it out of FILE, + ;; or the current buffer if FILE is nil. + ;; This may be a name-address pair, or an address by itself, + (save-excursion + (if file + (find-file file)) + (prog1 + (let ((raw-address + (or + (save-excursion (lm-header "maintainer")) + (car (lm-authors))))) + (cond ((string-match "[^<]<\\([^>]+\\)>" raw-address) + (substring raw-address (match-beginning 1) (match-end 1))) + (t raw-address)) + ) + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-creation-date (&optional file) + ;; Return a package's creation date, if any. Parse it out of FILE, + ;; or the current buffer if FILE is nil. + (save-excursion + (if file + (find-file file)) + (prog1 + (lm-header "created") + (if file + (kill-buffer (current-buffer))) + ))) + + +(defun lm-last-modified-date (&optional file) + ;; Return a package's last-modified date, if you can find one. + (save-excursion + (if file + (find-file file)) + (prog1 + (if (progn + (goto-char (point-min)) + (re-search-forward + "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) " + (lm-code-mark) t)) + (format "%s %s %s" + (buffer-substring (match-beginning 3) (match-end 3)) + (nth (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))) + '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + (buffer-substring (match-beginning 1) (match-end 1)) + ))) + (if file + (kill-buffer (current-buffer))) + )) + +(defun lm-version (&optional file) + ;; Return the package's version field. + ;; If none, look for an RCS or SCCS header to crack it out of. + (save-excursion + (if file + (find-file file)) + (prog1 + (or + (lm-header "version") + (let ((header-max (lm-code-mark))) + (goto-char (point-min)) + (cond + ;; Look for an RCS header + ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t) + (buffer-substring (match-beginning 1) (match-end 1))) + + ;; Look for an SCCS header + ((re-search-forward + (concat + (regexp-quote "@(#)") + (regexp-quote (file-name-nondirectory (buffer-file-name))) + "\t\\([012345679.]*\\)") + header-max t) + (buffer-substring (match-beginning 1) (match-end 1))) + + (t nil)))) + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-keywords (&optional file) + ;; Return the header containing the package's topic keywords. + ;; Parse them out of FILE, or the current buffer if FILE is nil. + (save-excursion + (if file + (find-file file)) + (prog1 + (let ((keywords (lm-header "keywords"))) + (and keywords (downcase keywords))) + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-adapted-by (&optional file) + ;; Return the name or code of the person who cleaned up this package + ;; for distribution. Parse it out of FILE, or the current buffer if + ;; FILE is nil. + (save-excursion + (if file + (find-file file)) + (prog1 + (lm-header "adapted-by") + (if file + (kill-buffer (current-buffer))) + ))) + +(defun lm-commentary-region (&optional file) + ;; Return a pair of character locations enclosing the commentary region. + (save-excursion + (if file + (find-file file)) + (prog1 + (let ((commentary (lm-section-mark "Commentary")) + (change-log (lm-section-mark "Change Log")) + (code (lm-section-mark "Code"))) + (if commentary + (if change-log + (cons commentary change-log) + (cons commentary code))) + ) + (if file + (kill-buffer (current-buffer))) + ))) + +;;; Verification and synopses + +(defun insert-at-column (col &rest pieces) + (if (> (current-column) col) (insert "\n")) + (move-to-column-force col) + (apply 'insert pieces)) + +(defconst lm-comment-column 16) + +(defun lm-verify (&optional file showok) + "Check that the current buffer (or FILE if given) is in proper format. +If FILE is a directory, recurse on its files and generate a report into +a temporary buffer." + (if (and file (file-directory-p file)) + (progn + (switch-to-buffer (get-buffer-create "*lm-verify*")) + (erase-buffer) + (mapcar + '(lambda (f) + (if (string-match ".*\\.el$" f) + (let ((status (lm-verify f))) + (if status + (progn + (insert f ":") + (insert-at-column lm-comment-column status "\n")) + (and showok + (progn + (insert f ":") + (insert-at-column lm-comment-column "OK\n"))))))) + (directory-files file)) + ) + (save-excursion + (if file + (find-file file)) + (prog1 + (cond + ((not (lm-summary)) + "Can't find a package summary") + ((not (lm-code-mark)) + "Can't find a code section marker") + ((progn + (goto-char (point-max)) + (forward-line -1) + (looking-at (concat ";;; " file "ends here"))) + "Can't find a footer line") + ) + (if file + (kill-buffer (current-buffer))) + )))) + +(defun lm-synopsis (&optional file showall) + "Generate a synopsis listing for the buffer or the given FILE if given. +If FILE is a directory, recurse on its files and generate a report into +a temporary buffer. If SHOWALL is on, also generate a line for files +which do not include a recognizable synopsis." + (if (and file (file-directory-p file)) + (progn + (switch-to-buffer (get-buffer-create "*lm-verify*")) + (erase-buffer) + (mapcar + '(lambda (f) + (if (string-match ".*\\.el$" f) + (let ((syn (lm-synopsis f))) + (if syn + (progn + (insert f ":") + (insert-at-column lm-comment-column syn "\n")) + (and showall + (progn + (insert f ":") + (insert-at-column lm-comment-column "NA\n"))))))) + (directory-files file)) + ) + (save-excursion + (if file + (find-file file)) + (prog1 + (lm-summary) + (if file + (kill-buffer (current-buffer))) + )))) + +(defun lm-report-bug (topic) + "Report a bug in the package currently being visited to its maintainer. +Prompts for bug subject. Leaves you in a mail buffer." + (let ((package (buffer-name)) + (addr (lm-maintainer)) + (version (lm-version))) + ;; We do this in order to avoid duplicating the general bug address here + (if (or (not addr) (string= "FSF")) + (progn + (load-library "emacsbug.el") + (emacsbug (format "%s --- %s" package topic)))) + (interactive "sBug Subject: ") + (mail nil addr topic) + (goto-char (point-max)) + (insert "\nIn " + package + (and version (concat " version " version)) + "\n\n") + (message + (substitute-command-keys "Type \\[mail-send] to send bug report.")))) + +(provide 'lisp-mnt) + +;;; lisp-mnt.el ends here