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 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.2 1993/03/25 01:57:43 eric Exp eric $
   9 ;; Keywords: docs
  10 ;; 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 ;;    * Bogus-Bureaucratic-Cruft line --- this is a joke.  I figured I should
  93 ;; satirize this design before someone else did.  Also, it illustrates the
  94 ;; possibility that other headers may be added in the future for new purposes.
  95 ;;
  96 ;;    * Commentary line --- enables lisp code to find the developer's and
  97 ;; maintainers' explanations of the package internals.
  98 ;;
  99 ;;    * Change log line --- optional, exists to terminate the commentary
 100 ;; section and start a change-log part, if one exists.
 101 ;;
 102 ;;    * Code line --- exists so elisp can know where commentary and/or
 103 ;; change-log sections end.
 104 ;;
 105 ;;    * Footer line --- marks end-of-file so it can be distinguished from
 106 ;; an expanded formfeed or the results of truncation.
 107
 108 ;;; Change Log:
 109
 110 ;; Tue Jul 14 23:44:17 1992     ESR
 111 ;;      * Created.
 112
 113 ;;; Code:
 114
 115 (require 'picture)              ; provides move-to-column-force
 116 (require 'emacsbug)
 117
 118 ;; These functions all parse the headers of the current buffer
 119
 120 (defun lm-section-mark (hd &optional after)
 121   ;; Return the buffer location of a given section start marker
 122   (save-excursion
 123     (let ((case-fold-search t))
 124       (goto-char (point-min))
 125       (if (re-search-forward (concat "^;;; " hd ":$") nil t)
 126           (progn
 127             (beginning-of-line)
 128             (if after (forward-line 1))
 129             (point))
 130         nil))))
 131
 132 (defun lm-code-mark ()
 133   ;; Return the buffer location of the code start marker
 134   (lm-section-mark "Code"))
 135
 136 (defun lm-header (hd)
 137   ;; Return the contents of a named header
 138     (goto-char (point-min))
 139     (let ((case-fold-search t))
 140       (if (re-search-forward
 141            (concat "^;; " hd ": \\(.*\\)") (lm-code-mark) t)
 142           (buffer-substring (match-beginning 1) (match-end 1))
 143         nil)))
 144
 145 (defun lm-header-multiline (hd)
 146   ;; Return the contents of a named header, with possible continuation lines.
 147   ;; Note -- the returned value is a list of strings, one per line.
 148   (save-excursion
 149     (goto-char (point-min))
 150     (let ((res (save-excursion (lm-header hd))))
 151       (if res
 152           (progn
 153             (forward-line 1)
 154             (setq res (list res))
 155             (while (looking-at "^;;\t\\(.*\\)")
 156               (setq res (cons (buffer-substring
 157                                (match-beginning 1)
 158                                (match-end 1))
 159                               res))
 160               (forward-line 1))
 161             ))
 162       res)))
 163
 164 ;; These give us smart access to the header fields and commentary
 165
 166 (defun lm-summary (&optional file)
 167   ;; Return the buffer's or FILE's one-line summary.
 168   (save-excursion
 169     (if file
 170         (find-file file))
 171     (goto-char (point-min))
 172     (prog1
 173       (if (looking-at "^;;; [^ ]+ --- \\(.*\\)")
 174           (buffer-substring (match-beginning 1) (match-end 1)))
 175       (if file
 176           (kill-buffer (current-buffer)))
 177       )))
 178
 179
 180 (defun lm-crack-address (x)
 181   ;; Given a string containing a human and email address, parse it
 182   ;; into a cons pair (name . address).
 183   (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
 184          (cons (substring x (match-beginning 1) (match-end 1))
 185                (substring x (match-beginning 2) (match-end 2))))
 186         ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
 187          (cons (substring x (match-beginning 2) (match-end 2))
 188                (substring x (match-beginning 1) (match-end 1))))
 189         ((string-match "\\S-+@\\S-+" x)
 190          (cons nil x))
 191         (t
 192          (cons x nil))))
 193
 194 (defun lm-authors (&optional file)
 195   ;; Return the buffer's or FILE's author list.  Each element of the
 196   ;; list is a cons; the car is a name-aming-humans, the cdr an email
 197   ;; address.
 198   (save-excursion
 199     (if file
 200         (find-file file))
 201     (let ((authorlist (lm-header-multiline "author")))
 202       (prog1
 203          (mapcar 'lm-crack-address authorlist)
 204           (if file
 205               (kill-buffer (current-buffer)))
 206         ))))
 207
 208 (defun lm-maintainer (&optional file)
 209   ;; Get a package's bug-report & maintenance address.  Parse it out of FILE,
 210   ;; or the current buffer if FILE is nil.
 211   ;; The return value is a (name . address) cons.
 212   (save-excursion
 213     (if file
 214         (find-file file))
 215     (prog1
 216         (let ((maint (lm-header "maintainer")))
 217           (if maint
 218               (lm-crack-address maint)
 219             (car (lm-authors))))
 220       (if file
 221           (kill-buffer (current-buffer)))
 222       )))
 223
 224 (defun lm-creation-date (&optional file)
 225   ;; Return a package's creation date, if any.  Parse it out of FILE,
 226   ;; or the current buffer if FILE is nil.
 227   (save-excursion
 228     (if file
 229         (find-file file))
 230     (prog1
 231         (lm-header "created")
 232       (if file
 233           (kill-buffer (current-buffer)))
 234       )))
 235
 236
 237 (defun lm-last-modified-date (&optional file)
 238   ;; Return a package's last-modified date, if you can find one.
 239   (save-excursion
 240     (if file
 241         (find-file file))
 242     (prog1
 243         (if (progn
 244               (goto-char (point-min))
 245               (re-search-forward
 246                "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
 247                (lm-code-mark) t))
 248             (format "%s %s %s"
 249                     (buffer-substring (match-beginning 3) (match-end 3))
 250                     (nth (string-to-int
 251                           (buffer-substring (match-beginning 2) (match-end 2)))
 252                          '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 253                            "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 254                     (buffer-substring (match-beginning 1) (match-end 1))
 255                     ))
 256       (if file
 257           (kill-buffer (current-buffer)))
 258       )))
 259
 260 (defun lm-version (&optional file)
 261   ;; Return the package's version field.
 262   ;; If none, look for an RCS or SCCS header to crack it out of.
 263   (save-excursion
 264     (if file
 265         (find-file file))
 266     (prog1
 267         (or
 268          (lm-header "version")
 269          (let ((header-max (lm-code-mark)))
 270            (goto-char (point-min))
 271            (cond
 272             ;; Look for an RCS header
 273             ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t)
 274              (buffer-substring (match-beginning 1) (match-end 1)))
 275
 276             ;; Look for an SCCS header
 277             ((re-search-forward
 278               (concat
 279                (regexp-quote "@(#)")
 280                (regexp-quote (file-name-nondirectory (buffer-file-name)))
 281                "\t\\([012345679.]*\\)")
 282               header-max t)
 283              (buffer-substring (match-beginning 1) (match-end 1)))
 284
 285             (t nil))))
 286       (if file
 287           (kill-buffer (current-buffer)))
 288       )))
 289
 290 (defun lm-keywords (&optional file)
 291   ;; Return the header containing the package's topic keywords.
 292   ;; Parse them out of FILE, or the current buffer if FILE is nil.
 293   (save-excursion
 294     (if file
 295         (find-file file))
 296     (prog1
 297         (let ((keywords (lm-header "keywords")))
 298           (and keywords (downcase keywords)))
 299       (if file
 300           (kill-buffer (current-buffer)))
 301       )))
 302
 303 (defun lm-adapted-by (&optional file)
 304   ;; Return the name or code of the person who cleaned up this package
 305   ;; for distribution.  Parse it out of FILE, or the current buffer if
 306   ;; FILE is nil.
 307   (save-excursion
 308     (if file
 309         (find-file file))
 310     (prog1
 311         (lm-header "adapted-by")
 312       (if file
 313           (kill-buffer (current-buffer)))
 314       )))
 315
 316 (defun lm-commentary (&optional file)
 317   ;; Return the commentary region of a file, as a string."
 318   (save-excursion
 319     (if file
 320         (find-file file))
 321     (prog1
 322         (let ((commentary (lm-section-mark "Commentary" t))
 323               (change-log (lm-section-mark "Change Log"))
 324               (code (lm-section-mark "Code")))
 325           (and commentary
 326               (if change-log
 327                   (buffer-substring commentary change-log)
 328                 (buffer-substring commentary code)))
 329           )
 330       (if file
 331           (kill-buffer (current-buffer)))
 332       )))
 333
 334 ;;; Verification and synopses
 335
 336 (defun insert-at-column (col &rest pieces)
 337    (if (> (current-column) col) (insert "\n"))
 338    (move-to-column-force col)
 339    (apply 'insert pieces))
 340
 341 (defconst lm-comment-column 16)
 342
 343 (defun lm-verify (&optional file showok)
 344   "Check that the current buffer (or FILE if given) is in proper format.
 345 If FILE is a directory, recurse on its files and generate a report into
 346 a temporary buffer."
 347   (if (and file (file-directory-p file))
 348       (progn
 349         (switch-to-buffer (get-buffer-create "*lm-verify*"))
 350         (erase-buffer)
 351         (mapcar
 352          '(lambda (f)
 353             (if (string-match ".*\\.el$" f)
 354                 (let ((status (lm-verify f)))
 355                   (if status
 356                       (progn
 357                         (insert f ":")
 358                         (insert-at-column lm-comment-column status "\n"))
 359                     (and showok
 360                          (progn
 361                            (insert f ":")
 362                            (insert-at-column lm-comment-column "OK\n")))))))
 363         (directory-files file))
 364     )
 365   (save-excursion
 366     (if file
 367         (find-file file))
 368     (prog1
 369         (cond
 370          ((not (lm-summary))
 371           "Can't find a package summary")
 372          ((not (lm-code-mark))
 373           "Can't find a code section marker")
 374          ((progn
 375             (goto-char (point-max))
 376             (forward-line -1)
 377             (looking-at (concat ";;; " file "ends here")))
 378           "Can't find a footer line")
 379          )
 380       (if file
 381           (kill-buffer (current-buffer)))
 382       ))))
 383
 384 (defun lm-synopsis (&optional file showall)
 385   "Generate a synopsis listing for the buffer or the given FILE if given.
 386 If FILE is a directory, recurse on its files and generate a report into
 387 a temporary buffer.  If SHOWALL is on, also generate a line for files
 388 which do not include a recognizable synopsis."
 389   (if (and file (file-directory-p file))
 390       (progn
 391         (switch-to-buffer (get-buffer-create "*lm-verify*"))
 392         (erase-buffer)
 393         (mapcar
 394          '(lambda (f)
 395             (if (string-match ".*\\.el$" f)
 396                 (let ((syn (lm-synopsis f)))
 397                   (if syn
 398                       (progn
 399                         (insert f ":")
 400                         (insert-at-column lm-comment-column syn "\n"))
 401                     (and showall
 402                          (progn
 403                            (insert f ":")
 404                            (insert-at-column lm-comment-column "NA\n")))))))
 405          (directory-files file))
 406         )
 407     (save-excursion
 408       (if file
 409           (find-file file))
 410       (prog1
 411           (lm-summary)
 412         (if file
 413             (kill-buffer (current-buffer)))
 414         ))))
 415
 416 (defun lm-report-bug (topic)
 417   "Report a bug in the package currently being visited to its maintainer.
 418 Prompts for bug subject.  Leaves you in a mail buffer."
 419   (interactive "sBug Subject: ")
 420   (let ((package (buffer-name))
 421         (addr (lm-maintainer))
 422         (version (lm-version)))
 423     (mail nil (or addr bug-gnu-emacs) topic)
 424     (goto-char (point-max))
 425     (insert "\nIn "
 426             package
 427             (and version (concat " version " version))
 428             "\n\n")
 429     (message
 430      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
 431
 432 (provide 'lisp-mnt)
 433
 434 ;;; lisp-mnt.el ends here