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.16 1996/02/06 21:35:20 erik 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 2, 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,  Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; This minor mode adds some services to Emacs-Lisp editing mode.
  32 ;;
  33 ;; First, it knows about the header conventions for library packages.
  34 ;; One entry point supports generating synopses from a library directory.
  35 ;; Another can be used to check for missing headers in library files.
  36 ;;
  37 ;; Another entry point automatically addresses bug mail to a package's
  38 ;; maintainer or author.
  39
  40 ;; This file can be loaded by your lisp-mode-hook.  Have it (require 'lisp-mnt)
  41
  42 ;; This file is an example of the header conventions.  Note the following
  43 ;; features:
  44 ;;
  45 ;;    * Header line --- makes it possible to extract a one-line summary of
  46 ;; the package's uses automatically for use in library synopses, KWIC
  47 ;; indexes and the like.
  48 ;;
  49 ;;    Format is three semicolons, followed by the filename, followed by
  50 ;; three dashes, followed by the summary.  All fields space-separated.
  51 ;;
  52 ;;    * Author line --- contains the name and net address of at least
  53 ;; the principal author.
  54 ;;
  55 ;;    If there are multiple authors, they should be listed on continuation
  56 ;; lines led by ;;<TAB>, like this:
  57 ;;
  58 ;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu>
  59 ;; ;;   Dave Sill <de5@ornl.gov>
  60 ;; ;;   David Lawrence <tale@pawl.rpi.edu>
  61 ;; ;;   Noah Friedman <friedman@ai.mit.edu>
  62 ;; ;;   Joe Wells <jbw@maverick.uswest.com>
  63 ;; ;;   Dave Brennan <brennan@hal.com>
  64 ;; ;;   Eric Raymond <esr@snark.thyrsus.com>
  65 ;;
  66 ;; This field may have some special values; notably "FSF", meaning
  67 ;; "Free Software Foundation".
  68 ;;
  69 ;;    * Maintainer line --- should be a single name/address as in the Author
  70 ;; line, or an address only, or the string "FSF".  If there is no maintainer
  71 ;; line, the person(s) in the Author field are presumed to be it.  The example
  72 ;; in this file is mildly bogus because the maintainer line is redundant.
  73 ;;    The idea behind these two fields is to be able to write a Lisp function
  74 ;; that does "send mail to the author" without having to mine the name out by
  75 ;; hand. Please be careful about surrounding the network address with <> if
  76 ;; there's also a name in the field.
  77 ;;
  78 ;;    * Created line --- optional, gives the original creation date of the
  79 ;; file.  For historical interest, basically.
  80 ;;
  81 ;;    * Version line --- intended to give the reader a clue if they're looking
  82 ;; at a different version of the file than the one they're accustomed to.  This
  83 ;; may be an RCS or SCCS header.
  84 ;;
  85 ;;    * Adapted-By line --- this is for FSF's internal use.  The person named
  86 ;; in this field was the one responsible for installing and adapting the
  87 ;; package for the distribution.  (This file doesn't have one because the
  88 ;; author *is* one of the maintainers.)
  89 ;;
  90 ;;    * Keywords line --- used by the finder code (now under construction)
  91 ;; for finding Emacs Lisp code related to a topic.
  92 ;;
  93 ;;    * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example
  94 ;; of a comment header.  Headers starting with `X-' should never be used
  95 ;; for any real purpose; this is the way to safely add random headers
  96 ;; without invoking the wrath of any program.
  97 ;;
  98 ;;    * Commentary line --- enables Lisp code to find the developer's and
  99 ;; maintainers' explanations of the package internals.
 100 ;;
 101 ;;    * Change log line --- optional, exists to terminate the commentary
 102 ;; section and start a change-log part, if one exists.
 103 ;;
 104 ;;    * Code line --- exists so Lisp can know where commentary and/or
 105 ;; change-log sections end.
 106 ;;
 107 ;;    * Footer line --- marks end-of-file so it can be distinguished from
 108 ;; an expanded formfeed or the results of truncation.
 109
 110 ;;; Change Log:
 111
 112 ;; Tue Jul 14 23:44:17 1992     ESR
 113 ;;      * Created.
 114
 115 ;;; Code:
 116
 117 (require 'picture)              ; provides move-to-column-force
 118 (require 'emacsbug)
 119
 120 ;;; Variables:
 121
 122 (defvar lm-header-prefix "^;;*[ \t]+\\(@\(#\)\\)?[ \t]*\\([\$]\\)?"
 123   "Prefix that is ignored before the tag.
 124 For example, you can write the 1st line synopsis string and headers like this
 125 in your Lisp package:
 126
 127    ;; @(#) package.el -- pacakge description
 128    ;;
 129    ;; @(#) $Maintainer:   Person Foo Bar $
 130
 131 The @(#) construct is used by unix what(1) and
 132 then $identifier: doc string $ is used by GNU ident(1)")
 133
 134 (defvar lm-comment-column 16
 135   "Column used for placing formatted output.")
 136
 137 (defvar lm-commentary-header "Commentary\\|Documentation"
 138   "Regexp which matches start of documentation section.")
 139
 140 (defvar lm-history-header "Change Log\\|History"
 141   "Regexp which matches the start of code log section.")
 142
 143 ;;; Functions:
 144
 145 ;; These functions all parse the headers of the current buffer
 146
 147 (defsubst lm-get-header-re (header &optional mode)
 148   "Returns regexp for matching HEADER.
 149 If called with optional MODE and with value `section',
 150 return section regexp instead."
 151   (cond ((eq mode 'section)
 152          (concat "^;;;;* " header ":[ \t]*$"))
 153         (t
 154          (concat lm-header-prefix header ":[ \t]*"))))
 155
 156 (defsubst lm-get-package-name ()
 157   "Returns package name by looking at the first line."
 158   (save-excursion
 159     (goto-char (point-min))
 160     (if (and (looking-at (concat lm-header-prefix))
 161              (progn (goto-char (match-end 0))
 162                     (looking-at "\\([^\t ]+\\)")
 163                     (match-end 1)))
 164         (buffer-substring (match-beginning 1) (match-end 1))
 165       )))
 166
 167 (defun lm-section-mark (header &optional after)
 168   "Return the buffer location of a given section start marker.
 169 The HEADER is the section mark string to search for.
 170 If AFTER is non-nil, return the location of the next line."
 171   (save-excursion
 172     (let ((case-fold-search t))
 173       (goto-char (point-min))
 174       (if (re-search-forward (lm-get-header-re header 'section) nil t)
 175           (progn
 176             (beginning-of-line)
 177             (if after (forward-line 1))
 178             (point))
 179         nil))))
 180
 181 (defsubst lm-code-mark ()
 182   "Return the buffer location of the `Code' start marker."
 183   (lm-section-mark "Code"))
 184
 185 (defsubst lm-commentary-mark ()
 186   "Return the buffer location of the `Commentary' start marker."
 187   (lm-section-mark lm-commentary-header))
 188
 189 (defsubst lm-history-mark ()
 190   "Return the buffer location of the `History' start marker."
 191   (lm-section-mark lm-history-header))
 192
 193 (defun lm-header (header)
 194   "Return the contents of the header named HEADER."
 195   (goto-char (point-min))
 196   (let ((case-fold-search t))
 197     (if (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t)
 198              ;;   RCS ident likes format "$identifier: data$"
 199              (looking-at "\\([^$\n]+\\)")
 200              (match-end 1))
 201         (buffer-substring (match-beginning 1) (match-end 1))
 202       nil)))
 203
 204 (defun lm-header-multiline (header)
 205   "Return the contents of the header named HEADER, with continuation lines.
 206 The returned value is a list of strings, one per line."
 207   (save-excursion
 208     (goto-char (point-min))
 209     (let ((res (lm-header header)))
 210       (cond
 211        (res
 212         (setq res (list res))
 213         (forward-line 1)
 214
 215         (while (and (looking-at (concat lm-header-prefix "[\t ]+"))
 216                     (progn
 217                       (goto-char (match-end 0))
 218                       (looking-at "\\(.*\\)"))
 219                     (match-end 1))
 220           (setq res (cons (buffer-substring
 221                            (match-beginning 1)
 222                            (match-end 1))
 223                           res))
 224           (forward-line 1))
 225         ))
 226       res
 227       )))
 228
 229 ;; These give us smart access to the header fields and commentary
 230
 231 (defun lm-summary (&optional file)
 232   "Return the one-line summary of file FILE, or current buffer if FILE is nil."
 233   (save-excursion
 234     (if file
 235         (find-file file))
 236     (goto-char (point-min))
 237     (prog1
 238       (if (and
 239            (looking-at lm-header-prefix)
 240            (progn (goto-char (match-end 0))
 241                   (looking-at "[^ ]+[ \t]+--+[ \t]+\\(.*\\)")))
 242           (buffer-substring (match-beginning 1) (match-end 1)))
 243       (if file
 244           (kill-buffer (current-buffer)))
 245       )))
 246
 247 (defun lm-crack-address (x)
 248   "Split up an email address into full name and real email address.
 249 The value is a cons of the form (FULLNAME . ADDRESS)."
 250   (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
 251          (cons (substring x (match-beginning 1) (match-end 1))
 252                (substring x (match-beginning 2) (match-end 2))))
 253         ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
 254          (cons (substring x (match-beginning 2) (match-end 2))
 255                (substring x (match-beginning 1) (match-end 1))))
 256         ((string-match "\\S-+@\\S-+" x)
 257          (cons nil x))
 258         (t
 259          (cons x nil))))
 260
 261 (defun lm-authors (&optional file)
 262   "Return the author list of file FILE, or current buffer if FILE is nil.
 263 Each element of the list is a cons; the car is the full name,
 264 the cdr is an email address."
 265   (save-excursion
 266     (if file
 267         (find-file file))
 268     (let ((authorlist (lm-header-multiline "author")))
 269       (prog1
 270          (mapcar 'lm-crack-address authorlist)
 271           (if file
 272               (kill-buffer (current-buffer)))
 273         ))))
 274
 275 (defun lm-maintainer (&optional file)
 276   "Return the maintainer of file FILE, or current buffer if FILE is nil.
 277 The return value has the form (NAME . ADDRESS)."
 278   (save-excursion
 279     (if file
 280         (find-file file))
 281     (prog1
 282         (let ((maint (lm-header "maintainer")))
 283           (if maint
 284               (lm-crack-address maint)
 285             (car (lm-authors))))
 286       (if file
 287           (kill-buffer (current-buffer)))
 288       )))
 289
 290 (defun lm-creation-date (&optional file)
 291   "Return the created date given in file FILE, or current buffer if FILE is nil."
 292   (save-excursion
 293     (if file
 294         (find-file file))
 295     (prog1
 296         (lm-header "created")
 297       (if file
 298           (kill-buffer (current-buffer)))
 299       )))
 300
 301
 302 (defun lm-last-modified-date (&optional file)
 303   "Return the modify-date given in file FILE, or current buffer if FILE is nil."
 304   (save-excursion
 305     (if file
 306         (find-file file))
 307     (prog1
 308         (if (progn
 309               (goto-char (point-min))
 310               (re-search-forward
 311                "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
 312                (lm-code-mark) t))
 313             (format "%s %s %s"
 314                     (buffer-substring (match-beginning 3) (match-end 3))
 315                     (nth (string-to-int
 316                           (buffer-substring (match-beginning 2) (match-end 2)))
 317                          '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 318                            "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 319                     (buffer-substring (match-beginning 1) (match-end 1))
 320                     ))
 321       (if file
 322           (kill-buffer (current-buffer)))
 323       )))
 324
 325 (defun lm-version (&optional file)
 326   "Return the version listed in file FILE, or current buffer if FILE is nil.
 327 This can befound in an RCS or SCCS header to crack it out of."
 328   (save-excursion
 329     (if file
 330         (find-file file))
 331     (prog1
 332         (or
 333          (lm-header "version")
 334          (let ((header-max (lm-code-mark)))
 335            (goto-char (point-min))
 336            (cond
 337             ;; Look for an RCS header
 338             ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t)
 339              (buffer-substring (match-beginning 1) (match-end 1)))
 340
 341             ;; Look for an SCCS header
 342             ((re-search-forward
 343               (concat
 344                (regexp-quote "@(#)")
 345                (regexp-quote (file-name-nondirectory (buffer-file-name)))
 346                "\t\\([012345679.]*\\)")
 347               header-max t)
 348              (buffer-substring (match-beginning 1) (match-end 1)))
 349
 350             (t nil))))
 351       (if file
 352           (kill-buffer (current-buffer)))
 353       )))
 354
 355 (defun lm-keywords (&optional file)
 356   "Return the keywords given in file FILE, or current buffer if FILE is nil."
 357   (save-excursion
 358     (if file
 359         (find-file file))
 360     (prog1
 361         (let ((keywords (lm-header "keywords")))
 362           (and keywords (downcase keywords)))
 363       (if file
 364           (kill-buffer (current-buffer)))
 365       )))
 366
 367 (defun lm-adapted-by (&optional file)
 368   "Return the adapted-by names in file FILE, or current buffer if FILE is nil.
 369 This is the name of the person who cleaned up this package for
 370 distribution."
 371   (save-excursion
 372     (if file
 373         (find-file file))
 374     (prog1
 375         (lm-header "adapted-by")
 376       (if file
 377           (kill-buffer (current-buffer)))
 378       )))
 379
 380 (defun lm-commentary (&optional file)
 381   "Return the commentary in file FILE, or current buffer if FILE is nil.
 382 The value is returned as a string.  In the text, the commentary starts
 383 with tag `Commentary' and ends with tag `Change Log' or `History'."
 384   (save-excursion
 385     (if file
 386         (find-file file))
 387     (prog1
 388         (let ((commentary       (lm-commentary-mark))
 389               (change-log       (lm-history-mark))
 390               (code             (lm-code-mark))
 391               )
 392           (cond
 393            ((and commentary change-log)
 394             (buffer-substring commentary change-log))
 395            ((and commentary code)
 396             (buffer-substring commentary code))
 397            (t
 398             nil)))
 399       (if file
 400           (kill-buffer (current-buffer)))
 401       )))
 402
 403 ;;; Verification and synopses
 404
 405 (defun lm-insert-at-column (col &rest strings)
 406   "Insert list of STRINGS, at column COL."
 407   (if (> (current-column) col) (insert "\n"))
 408   (move-to-column-force col)
 409   (apply 'insert strings))
 410
 411 (defun lm-verify (&optional file showok &optional verb)
 412   "Check that the current buffer (or FILE if given) is in proper format.
 413 If FILE is a directory, recurse on its files and generate a report in
 414 a temporary buffer."
 415   (interactive)
 416   (let* ((verb    (or verb (interactive-p)))
 417          ret
 418          name
 419          )
 420     (if verb
 421         (setq ret "Ok."))               ;init value
 422
 423     (if (and file (file-directory-p file))
 424         (setq
 425          ret
 426          (progn
 427            (switch-to-buffer (get-buffer-create "*lm-verify*"))
 428            (erase-buffer)
 429            (mapcar
 430             '(lambda (f)
 431                (if (string-match ".*\\.el$" f)
 432                    (let ((status (lm-verify f)))
 433                      (if status
 434                          (progn
 435                            (insert f ":")
 436                            (lm-insert-at-column lm-comment-column status "\n"))
 437                        (and showok
 438                             (progn
 439                               (insert f ":")
 440                               (lm-insert-at-column lm-comment-column "OK\n")))))))
 441             (directory-files file))
 442            ))
 443       (save-excursion
 444         (if file
 445             (find-file file))
 446         (setq name (lm-get-package-name))
 447
 448         (setq
 449          ret
 450          (prog1
 451              (cond
 452               ((null name)
 453                "Can't find a package NAME")
 454
 455               ((not (lm-authors))
 456                "Author: tag missing.")
 457
 458               ((not (lm-maintainer))
 459                "Maintainer: tag missing.")
 460
 461               ((not (lm-summary))
 462                "Can't find a one-line 'Summary' description")
 463
 464               ((not (lm-keywords))
 465                "Keywords: tag missing.")
 466
 467               ((not (lm-commentary-mark))
 468                "Can't find a 'Commentary' section marker.")
 469
 470               ((not (lm-history-mark))
 471                "Can't find a 'History' section marker.")
 472
 473               ((not (lm-code-mark))
 474                "Can't find a 'Code' section marker")
 475
 476               ((progn
 477                  (goto-char (point-max))
 478                  (not
 479                   (re-search-backward
 480                    (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$"
 481                            "\\|^;;;[ \t]+ End of file[ \t]+" name)
 482                    nil t
 483                    )))
 484                (format "Can't find a footer line for [%s]" name))
 485               (t
 486                ret))
 487            (if file
 488                (kill-buffer (current-buffer)))
 489           ))))
 490     (if verb
 491         (message ret))
 492     ret
 493     ))
 494
 495 (defun lm-synopsis (&optional file showall)
 496   "Generate a synopsis listing for the buffer or the given FILE if given.
 497 If FILE is a directory, recurse on its files and generate a report in
 498 a temporary buffer.  If SHOWALL is non-nil, also generate a line for files
 499 which do not include a recognizable synopsis."
 500   (interactive
 501    (list
 502     (read-file-name "Synopsis for (file or dir): ")))
 503
 504   (if (and file (file-directory-p file))
 505       (progn
 506         (switch-to-buffer (get-buffer-create "*lm-verify*"))
 507         (erase-buffer)
 508         (mapcar
 509          '(lambda (f)
 510             (if (string-match ".*\\.el$" f)
 511                 (let ((syn (lm-synopsis f)))
 512                   (if syn
 513                       (progn
 514                         (insert f ":")
 515                         (lm-insert-at-column lm-comment-column syn "\n"))
 516                     (and showall
 517                          (progn
 518                            (insert f ":")
 519                            (lm-insert-at-column lm-comment-column "NA\n")))))))
 520          (directory-files file))
 521         )
 522     (save-excursion
 523       (if file
 524           (find-file file))
 525       (prog1
 526           (lm-summary)
 527         (if file
 528             (kill-buffer (current-buffer)))
 529         ))))
 530
 531 (defun lm-report-bug (topic)
 532   "Report a bug in the package currently being visited to its maintainer.
 533 Prompts for bug subject.  Leaves you in a mail buffer."
 534   (interactive "sBug Subject: ")
 535   (let ((package        (lm-get-package-name))
 536         (addr           (lm-maintainer))
 537         (version        (lm-version)))
 538     (mail nil
 539           (if addr
 540               (concat (car addr) " <" (cdr addr) ">")
 541             bug-gnu-emacs)
 542           topic)
 543     (goto-char (point-max))
 544     (insert "\nIn "
 545             package
 546             (if version (concat " version " version) "")
 547             "\n\n")
 548     (message
 549      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
 550
 551 (provide 'lisp-mnt)
 552
 553 ;;; lisp-mnt.el ends here
 554