code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/lisp-mnt.el

   1 ;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers
   2
   3 ;; Copyright (C) 1992, 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
   6 ;; Maintainer: Eric S. Raymond <esr@snark.thyrsus.com>
   7 ;; Created: 14 Jul 1992
   8 ;; Version: $Id: lisp-mnt.el,v 1.8 1994/05/03 23:21:00 kwzh Exp rms $
   9 ;; Keywords: docs
  10 ;; X-Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out!
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 1, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  26 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This minor mode adds some services to Emacs-Lisp editing mode.
  31 ;;
  32 ;; First, it knows about the header conventions for library packages.
  33 ;; One entry point supports generating synopses from a library directory.
  34 ;; Another can be used to check for missing headers in library files.
  35 ;;
  36 ;; Another entry point automatically addresses bug mail to a package's
  37 ;; maintainer or author.
  38
  39 ;; This file can be loaded by your lisp-mode-hook.  Have it (require 'lisp-mnt)
  40
  41 ;; This file is an example of the header conventions.  Note the following
  42 ;; features:
  43 ;;
  44 ;;    * Header line --- makes it possible to extract a one-line summary of
  45 ;; the package's uses automatically for use in library synopses, KWIC
  46 ;; indexes and the like.
  47 ;;
  48 ;;    Format is three semicolons, followed by the filename, followed by
  49 ;; three dashes, followed by the summary.  All fields space-separated.
  50 ;;
  51 ;;    * Author line --- contains the name and net address of at least
  52 ;; the principal author.
  53 ;;
  54 ;;    If there are multiple authors, they should be listed on continuation
  55 ;; lines led by ;;<TAB>, like this:
  56 ;;
  57 ;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu>
  58 ;; ;;   Dave Sill <de5@ornl.gov>
  59 ;; ;;   David Lawrence <tale@pawl.rpi.edu>
  60 ;; ;;   Noah Friedman <friedman@ai.mit.edu>
  61 ;; ;;   Joe Wells <jbw@maverick.uswest.com>
  62 ;; ;;   Dave Brennan <brennan@hal.com>
  63 ;; ;;   Eric Raymond <esr@snark.thyrsus.com>
  64 ;;
  65 ;; This field may have some special values; notably "FSF", meaning
  66 ;; "Free Software Foundation".
  67 ;;
  68 ;;    * Maintainer line --- should be a single name/address as in the Author
  69 ;; line, or an address only, or the string "FSF".  If there is no maintainer
  70 ;; line, the person(s) in the Author field are presumed to be it.  The example
  71 ;; in this file is mildly bogus because the maintainer line is redundant.
  72 ;;    The idea behind these two fields is to be able to write a lisp function
  73 ;; that does "send mail to the author" without having to mine the name out by
  74 ;; hand. Please be careful about surrounding the network address with <> if
  75 ;; there's also a name in the field.
  76 ;;
  77 ;;    * Created line --- optional, gives the original creation date of the
  78 ;; file.  For historical interest, basically.
  79 ;;
  80 ;;    * Version line --- intended to give the reader a clue if they're looking
  81 ;; at a different version of the file than the one they're accustomed to.  This
  82 ;; may be an RCS or SCCS header.
  83 ;;
  84 ;;    * Adapted-By line --- this is for FSF's internal use.  The person named
  85 ;; in this field was the one responsible for installing and adapting the
  86 ;; package for the distribution.  (This file doesn't have one because the
  87 ;; author *is* one of the maintainers.)
  88 ;;
  89 ;;    * Keywords line --- used by the finder code (now under construction)
  90 ;; for finding elisp code related to a topic.
  91 ;;
  92 ;;    * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example
  93 ;; of a comment header.  Headers starting with `X-' should never be used
  94 ;; for any real purpose; this is the way to safely add random headers
  95 ;; without invoking the wrath of any program.
  96 ;;
  97 ;;    * Commentary line --- enables lisp code to find the developer's and
  98 ;; maintainers' explanations of the package internals.
  99 ;;
 100 ;;    * Change log line --- optional, exists to terminate the commentary
 101 ;; section and start a change-log part, if one exists.
 102 ;;
 103 ;;    * Code line --- exists so elisp can know where commentary and/or
 104 ;; change-log sections end.
 105 ;;
 106 ;;    * Footer line --- marks end-of-file so it can be distinguished from
 107 ;; an expanded formfeed or the results of truncation.
 108
 109 ;;; Change Log:
 110
 111 ;; Tue Jul 14 23:44:17 1992     ESR
 112 ;;      * Created.
 113
 114 ;;; Code:
 115
 116 (require 'picture)              ; provides move-to-column-force
 117 (require 'emacsbug)
 118
 119 ;; These functions all parse the headers of the current buffer
 120
 121 (defun lm-section-mark (hd &optional after)
 122   ;; Return the buffer location of a given section start marker
 123   (save-excursion
 124     (let ((case-fold-search t))
 125       (goto-char (point-min))
 126       (if (re-search-forward (concat "^;;;;* " hd ":[ \t]*$") nil t)
 127           (progn
 128             (beginning-of-line)
 129             (if after (forward-line 1))
 130             (point))
 131         nil))))
 132
 133 (defun lm-code-mark ()
 134   ;; Return the buffer location of the code start marker
 135   (lm-section-mark "Code"))
 136
 137 (defun lm-header (hd)
 138   ;; Return the contents of a named header
 139     (goto-char (point-min))
 140     (let ((case-fold-search t))
 141       (if (re-search-forward
 142            (concat "^;; " hd ": \\(.*\\)") (lm-code-mark) t)
 143           (buffer-substring (match-beginning 1) (match-end 1))
 144         nil)))
 145
 146 (defun lm-header-multiline (hd)
 147   ;; Return the contents of a named header, with possible continuation lines.
 148   ;; Note -- the returned value is a list of strings, one per line.
 149   (save-excursion
 150     (goto-char (point-min))
 151     (let ((res (save-excursion (lm-header hd))))
 152       (if res
 153           (progn
 154             (forward-line 1)
 155             (setq res (list res))
 156             (while (looking-at "^;;\t\\(.*\\)")
 157               (setq res (cons (buffer-substring
 158                                (match-beginning 1)
 159                                (match-end 1))
 160                               res))
 161               (forward-line 1))
 162             ))
 163       res)))
 164
 165 ;; These give us smart access to the header fields and commentary
 166
 167 (defun lm-summary (&optional file)
 168   ;; Return the buffer's or FILE's one-line summary.
 169   (save-excursion
 170     (if file
 171         (find-file file))
 172     (goto-char (point-min))
 173     (prog1
 174       (if (looking-at "^;;; [^ ]+ --- \\(.*\\)")
 175           (buffer-substring (match-beginning 1) (match-end 1)))
 176       (if file
 177           (kill-buffer (current-buffer)))
 178       )))
 179
 180
 181 (defun lm-crack-address (x)
 182   ;; Given a string containing a human and email address, parse it
 183   ;; into a cons pair (name . address).
 184   (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
 185          (cons (substring x (match-beginning 1) (match-end 1))
 186                (substring x (match-beginning 2) (match-end 2))))
 187         ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
 188          (cons (substring x (match-beginning 2) (match-end 2))
 189                (substring x (match-beginning 1) (match-end 1))))
 190         ((string-match "\\S-+@\\S-+" x)
 191          (cons nil x))
 192         (t
 193          (cons x nil))))
 194
 195 (defun lm-authors (&optional file)
 196   ;; Return the buffer's or FILE's author list.  Each element of the
 197   ;; list is a cons; the car is a name-aming-humans, the cdr an email
 198   ;; address.
 199   (save-excursion
 200     (if file
 201         (find-file file))
 202     (let ((authorlist (lm-header-multiline "author")))
 203       (prog1
 204          (mapcar 'lm-crack-address authorlist)
 205           (if file
 206               (kill-buffer (current-buffer)))
 207         ))))
 208
 209 (defun lm-maintainer (&optional file)
 210   ;; Get a package's bug-report & maintenance address.  Parse it out of FILE,
 211   ;; or the current buffer if FILE is nil.
 212   ;; The return value is a (name . address) cons.
 213   (save-excursion
 214     (if file
 215         (find-file file))
 216     (prog1
 217         (let ((maint (lm-header "maintainer")))
 218           (if maint
 219               (lm-crack-address maint)
 220             (car (lm-authors))))
 221       (if file
 222           (kill-buffer (current-buffer)))
 223       )))
 224
 225 (defun lm-creation-date (&optional file)
 226   ;; Return a package's creation date, if any.  Parse it out of FILE,
 227   ;; or the current buffer if FILE is nil.
 228   (save-excursion
 229     (if file
 230         (find-file file))
 231     (prog1
 232         (lm-header "created")
 233       (if file
 234           (kill-buffer (current-buffer)))
 235       )))
 236
 237
 238 (defun lm-last-modified-date (&optional file)
 239   ;; Return a package's last-modified date, if you can find one.
 240   (save-excursion
 241     (if file
 242         (find-file file))
 243     (prog1
 244         (if (progn
 245               (goto-char (point-min))
 246               (re-search-forward
 247                "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
 248                (lm-code-mark) t))
 249             (format "%s %s %s"
 250                     (buffer-substring (match-beginning 3) (match-end 3))
 251                     (nth (string-to-int
 252                           (buffer-substring (match-beginning 2) (match-end 2)))
 253                          '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 254                            "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 255                     (buffer-substring (match-beginning 1) (match-end 1))
 256                     ))
 257       (if file
 258           (kill-buffer (current-buffer)))
 259       )))
 260
 261 (defun lm-version (&optional file)
 262   ;; Return the package's version field.
 263   ;; If none, look for an RCS or SCCS header to crack it out of.
 264   (save-excursion
 265     (if file
 266         (find-file file))
 267     (prog1
 268         (or
 269          (lm-header "version")
 270          (let ((header-max (lm-code-mark)))
 271            (goto-char (point-min))
 272            (cond
 273             ;; Look for an RCS header
 274             ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t)
 275              (buffer-substring (match-beginning 1) (match-end 1)))
 276
 277             ;; Look for an SCCS header
 278             ((re-search-forward
 279               (concat
 280                (regexp-quote "@(#)")
 281                (regexp-quote (file-name-nondirectory (buffer-file-name)))
 282                "\t\\([012345679.]*\\)")
 283               header-max t)
 284              (buffer-substring (match-beginning 1) (match-end 1)))
 285
 286             (t nil))))
 287       (if file
 288           (kill-buffer (current-buffer)))
 289       )))
 290
 291 (defun lm-keywords (&optional file)
 292   ;; Return the header containing the package's topic keywords.
 293   ;; Parse them out of FILE, or the current buffer if FILE is nil.
 294   (save-excursion
 295     (if file
 296         (find-file file))
 297     (prog1
 298         (let ((keywords (lm-header "keywords")))
 299           (and keywords (downcase keywords)))
 300       (if file
 301           (kill-buffer (current-buffer)))
 302       )))
 303
 304 (defun lm-adapted-by (&optional file)
 305   ;; Return the name or code of the person who cleaned up this package
 306   ;; for distribution.  Parse it out of FILE, or the current buffer if
 307   ;; FILE is nil.
 308   (save-excursion
 309     (if file
 310         (find-file file))
 311     (prog1
 312         (lm-header "adapted-by")
 313       (if file
 314           (kill-buffer (current-buffer)))
 315       )))
 316
 317 (defun lm-commentary (&optional file)
 318   ;; Return the commentary region of a file, as a string.
 319   (save-excursion
 320     (if file
 321         (find-file file))
 322     (prog1
 323         (let ((commentary (lm-section-mark "Commentary" t))
 324               (change-log (lm-section-mark "Change Log"))
 325               (code (lm-section-mark "Code")))
 326           (and commentary
 327               (if change-log
 328                   (buffer-substring commentary change-log)
 329                 (buffer-substring commentary code)))
 330           )
 331       (if file
 332           (kill-buffer (current-buffer)))
 333       )))
 334
 335 ;;; Verification and synopses
 336
 337 (defun insert-at-column (col &rest pieces)
 338    (if (> (current-column) col) (insert "\n"))
 339    (move-to-column-force col)
 340    (apply 'insert pieces))
 341
 342 (defconst lm-comment-column 16)
 343
 344 (defun lm-verify (&optional file showok)
 345   "Check that the current buffer (or FILE if given) is in proper format.
 346 If FILE is a directory, recurse on its files and generate a report into
 347 a temporary buffer."
 348   (if (and file (file-directory-p file))
 349       (progn
 350         (switch-to-buffer (get-buffer-create "*lm-verify*"))
 351         (erase-buffer)
 352         (mapcar
 353          '(lambda (f)
 354             (if (string-match ".*\\.el$" f)
 355                 (let ((status (lm-verify f)))
 356                   (if status
 357                       (progn
 358                         (insert f ":")
 359                         (insert-at-column lm-comment-column status "\n"))
 360                     (and showok
 361                          (progn
 362                            (insert f ":")
 363                            (insert-at-column lm-comment-column "OK\n")))))))
 364         (directory-files file))
 365     )
 366   (save-excursion
 367     (if file
 368         (find-file file))
 369     (prog1
 370         (cond
 371          ((not (lm-summary))
 372           "Can't find a package summary")
 373          ((not (lm-code-mark))
 374           "Can't find a code section marker")
 375          ((progn
 376             (goto-char (point-max))
 377             (forward-line -1)
 378             (looking-at (concat ";;; " file "ends here")))
 379           "Can't find a footer line")
 380          )
 381       (if file
 382           (kill-buffer (current-buffer)))
 383       ))))
 384
 385 (defun lm-synopsis (&optional file showall)
 386   "Generate a synopsis listing for the buffer or the given FILE if given.
 387 If FILE is a directory, recurse on its files and generate a report into
 388 a temporary buffer.  If SHOWALL is on, also generate a line for files
 389 which do not include a recognizable synopsis."
 390   (if (and file (file-directory-p file))
 391       (progn
 392         (switch-to-buffer (get-buffer-create "*lm-verify*"))
 393         (erase-buffer)
 394         (mapcar
 395          '(lambda (f)
 396             (if (string-match ".*\\.el$" f)
 397                 (let ((syn (lm-synopsis f)))
 398                   (if syn
 399                       (progn
 400                         (insert f ":")
 401                         (insert-at-column lm-comment-column syn "\n"))
 402                     (and showall
 403                          (progn
 404                            (insert f ":")
 405                            (insert-at-column lm-comment-column "NA\n")))))))
 406          (directory-files file))
 407         )
 408     (save-excursion
 409       (if file
 410           (find-file file))
 411       (prog1
 412           (lm-summary)
 413         (if file
 414             (kill-buffer (current-buffer)))
 415         ))))
 416
 417 (defun lm-report-bug (topic)
 418   "Report a bug in the package currently being visited to its maintainer.
 419 Prompts for bug subject.  Leaves you in a mail buffer."
 420   (interactive "sBug Subject: ")
 421   (let ((package (buffer-name))
 422         (addr (lm-maintainer))
 423         (version (lm-version)))
 424     (mail nil
 425           (if addr
 426               (concat (car addr) " <" (cdr addr) ">")
 427             bug-gnu-emacs)
 428           topic)
 429     (goto-char (point-max))
 430     (insert "\nIn "
 431             package
 432             (if version (concat " version " version) "")
 433             "\n\n")
 434     (message
 435      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
 436
 437 (provide 'lisp-mnt)
 438
 439 ;;; lisp-mnt.el ends here