lisp/emacs-lisp/lisp-mnt.el

   1 ;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers
   2
   3 ;; Copyright (C) 1992, 1994, 1997, 2000, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
   6 ;; Maintainer: FSF
   7 ;; Created: 14 Jul 1992
   8 ;; Keywords: docs
   9 ;; X-Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out!
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation,  Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, 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 ;;    * A blank line
  52 ;;
  53 ;;    * Copyright line, which looks more or less like this:
  54 ;;
  55 ;;       ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
  56 ;;
  57 ;;    * A blank line
  58 ;;
  59 ;;    * Author line --- contains the name and net address of at least
  60 ;; the principal author.
  61 ;;
  62 ;;    If there are multiple authors, they should be listed on continuation
  63 ;; lines led by ;;<TAB>, like this:
  64 ;;
  65 ;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu>
  66 ;; ;;   Dave Sill <de5@ornl.gov>
  67 ;; ;;   David Lawrence <tale@pawl.rpi.edu>
  68 ;; ;;   Noah Friedman <friedman@ai.mit.edu>
  69 ;; ;;   Joe Wells <jbw@maverick.uswest.com>
  70 ;; ;;   Dave Brennan <brennan@hal.com>
  71 ;; ;;   Eric Raymond <esr@snark.thyrsus.com>
  72 ;;
  73 ;; This field may have some special values; notably "FSF", meaning
  74 ;; "Free Software Foundation".
  75 ;;
  76 ;;    * Maintainer line --- should be a single name/address as in the Author
  77 ;; line, or an address only, or the string "FSF".  If there is no maintainer
  78 ;; line, the person(s) in the Author field are presumed to be it.  The example
  79 ;; in this file is mildly bogus because the maintainer line is redundant.
  80 ;;    The idea behind these two fields is to be able to write a Lisp function
  81 ;; that does "send mail to the author" without having to mine the name out by
  82 ;; hand. Please be careful about surrounding the network address with <> if
  83 ;; there's also a name in the field.
  84 ;;
  85 ;;    * Created line --- optional, gives the original creation date of the
  86 ;; file.  For historical interest, basically.
  87 ;;
  88 ;;    * Version line --- intended to give the reader a clue if they're looking
  89 ;; at a different version of the file than the one they're accustomed to.  This
  90 ;; may be an RCS or SCCS header.
  91 ;;
  92 ;;    * Adapted-By line --- this is for FSF's internal use.  The person named
  93 ;; in this field was the one responsible for installing and adapting the
  94 ;; package for the distribution.  (This file doesn't have one because the
  95 ;; author *is* one of the maintainers.)
  96 ;;
  97 ;;    * Keywords line --- used by the finder code (now under construction)
  98 ;; for finding Emacs Lisp code related to a topic.
  99 ;;
 100 ;;    * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example
 101 ;; of a comment header.  Headers starting with `X-' should never be used
 102 ;; for any real purpose; this is the way to safely add random headers
 103 ;; without invoking the wrath of any program.
 104 ;;
 105 ;;    * Commentary line --- enables Lisp code to find the developer's and
 106 ;; maintainers' explanations of the package internals.
 107 ;;
 108 ;;    * Change log line --- optional, exists to terminate the commentary
 109 ;; section and start a change-log part, if one exists.
 110 ;;
 111 ;;    * Code line --- exists so Lisp can know where commentary and/or
 112 ;; change-log sections end.
 113 ;;
 114 ;;    * Footer line --- marks end-of-file so it can be distinguished from
 115 ;; an expanded formfeed or the results of truncation.
 116
 117 ;;; Change Log:
 118
 119 ;; Tue Jul 14 23:44:17 1992     ESR
 120 ;;      * Created.
 121
 122 ;;; Code:
 123
 124 ;;; Variables:
 125
 126 (defgroup lisp-mnt nil
 127   "Minor mode for Emacs Lisp maintainers."
 128   :prefix "lm-"
 129   :group 'maint)
 130
 131 ;; At least some of these defcustoms should probably be defconsts,
 132 ;; since they define, or are defined by, the header format.  -- fx
 133
 134 (defcustom lm-header-prefix "^;+[ \t]+\\(@(#)\\)?[ \t]*\\$?"
 135   "Prefix that is ignored before the tag.
 136 For example, you can write the 1st line synopsis string and headers like this
 137 in your Lisp package:
 138
 139    ;; @(#) package.el -- package description
 140    ;;
 141    ;; @(#) $Maintainer:   Person Foo Bar $
 142
 143 The @(#) construct is used by unix what(1) and
 144 then $identifier: doc string $ is used by GNU ident(1)"
 145   :type 'regexp
 146   :group 'lisp-mnt)
 147
 148 (defcustom lm-copyright-prefix "^\\(;+[ \t]\\)+Copyright (C) "
 149   "Prefix that is ignored before the dates in a copyright.
 150 Leading comment characters and whitespace should be in regexp group 1."
 151   :type 'regexp
 152   :group 'lisp-mnt)
 153
 154 (defcustom lm-comment-column 16
 155   "Column used for placing formatted output."
 156   :type 'integer
 157   :group 'lisp-mnt)
 158
 159 (defcustom lm-commentary-header "Commentary\\|Documentation"
 160   "Regexp which matches start of documentation section."
 161   :type 'regexp
 162   :group 'lisp-mnt)
 163
 164 (defcustom lm-history-header "Change ?Log\\|History"
 165   "Regexp which matches the start of code log section."
 166   :type 'regexp
 167   :group 'lisp-mnt)
 168
 169 ;;; Functions:
 170
 171 ;; These functions all parse the headers of the current buffer
 172
 173 (defun lm-get-header-re (header &optional mode)
 174   "Return regexp for matching HEADER.
 175 If called with optional MODE and with value `section',
 176 return section regexp instead."
 177   (if (eq mode 'section)
 178       (concat "^;;;;* " header ":[ \t]*$")
 179     (concat lm-header-prefix header "[ \t]*:[ \t]*")))
 180
 181 (defun lm-get-package-name ()
 182   "Return package name by looking at the first line."
 183   (save-excursion
 184     (goto-char (point-min))
 185     (if (and (looking-at (concat lm-header-prefix))
 186              (progn (goto-char (match-end 0))
 187                     (looking-at "\\([^\t ]+\\)")
 188                     (match-end 1)))
 189         (match-string-no-properties 1))))
 190
 191 (defun lm-section-mark (header &optional after)
 192   "Return the buffer location of a given section start marker.
 193 The HEADER is the section mark string to search for.
 194 If AFTER is non-nil, return the location of the next line."
 195   (save-excursion
 196     (let ((case-fold-search t))
 197       (goto-char (point-min))
 198       (if (re-search-forward (lm-get-header-re header 'section) nil t)
 199           (progn
 200             (beginning-of-line)
 201             (if after (forward-line 1))
 202             (point))))))
 203
 204 (defsubst lm-code-mark ()
 205   "Return the buffer location of the `Code' start marker."
 206   (lm-section-mark "Code"))
 207
 208 (defsubst lm-commentary-mark ()
 209   "Return the buffer location of the `Commentary' start marker."
 210   (lm-section-mark lm-commentary-header))
 211
 212 (defsubst lm-history-mark ()
 213   "Return the buffer location of the `History' start marker."
 214   (lm-section-mark lm-history-header))
 215
 216 (defsubst lm-copyright-mark ()
 217   "Return the buffer location of the `Copyright' line."
 218   (save-excursion
 219     (let ((case-fold-search t))
 220       (goto-char (point-min))
 221       (if (re-search-forward lm-copyright-prefix nil t)
 222           (point))))
 223   )
 224
 225 (defun lm-header (header)
 226   "Return the contents of the header named HEADER."
 227   (goto-char (point-min))
 228   (let ((case-fold-search t))
 229     (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t)
 230                ;;   RCS ident likes format "$identifier: data$"
 231                (looking-at
 232                 (if (save-excursion
 233                       (skip-chars-backward "^$" (match-beginning 0))
 234                       (= (point) (match-beginning 0)))
 235                     "[^\n]+" "[^$\n]+")))
 236       (match-string-no-properties 0))))
 237
 238 (defun lm-header-multiline (header)
 239   "Return the contents of the header named HEADER, with continuation lines.
 240 The returned value is a list of strings, one per line."
 241   (save-excursion
 242     (goto-char (point-min))
 243     (let ((res (lm-header header)))
 244       (when res
 245         (setq res (list res))
 246         (forward-line 1)
 247         (while (and (or (looking-at (concat lm-header-prefix "[\t ]+"))
 248                         (and (not (looking-at
 249                                    (lm-get-header-re "\\sw\\(\\sw\\|\\s_\\)*")))
 250                              (looking-at lm-header-prefix)))
 251                     (goto-char (match-end 0))
 252                     (looking-at ".+"))
 253           (setq res (cons (match-string-no-properties 0) res))
 254           (forward-line 1)))
 255       (nreverse res))))
 256
 257 ;; These give us smart access to the header fields and commentary
 258
 259 (defmacro lm-with-file (file &rest body)
 260   "Make a buffer with FILE current, and execute BODY.
 261 If FILE isn't in a buffer, load it in, and kill it after BODY is executed."
 262   (let ((filesym (make-symbol "file")))
 263     `(save-excursion
 264        (let ((,filesym ,file))
 265          (if ,filesym (set-buffer (find-file-noselect ,filesym)))
 266          (prog1 (progn ,@body)
 267            (if (and ,filesym (not (get-buffer-window (current-buffer) t)))
 268                (kill-buffer (current-buffer))))))))
 269 (put 'lm-with-file 'lisp-indent-function 1)
 270 (put 'lm-with-file 'edebug-form-spec t)
 271
 272 ;; Fixme: Probably this should be amalgamated with copyright.el; also
 273 ;; we need a check for ranges in copyright years.
 274
 275 (defun lm-crack-copyright (&optional file)
 276   "Return the copyright holder, and a list of copyright years.
 277 Use the current buffer if FILE is nil.
 278 Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")"
 279   (lm-with-file file
 280     (goto-char (lm-copyright-mark))
 281     (let ((holder nil)
 282           (years nil)
 283           (start (point))
 284           (end (line-end-position)))
 285       ;; Cope with multi-line copyright `lines'.  Assume the second
 286       ;; line is indented (with the same commenting style).
 287       (save-excursion
 288         (beginning-of-line 2)
 289         (let ((str (concat (match-string-no-properties 1) "[ \t]+")))
 290           (beginning-of-line)
 291           (while (looking-at str)
 292             (setq end (line-end-position))
 293             (beginning-of-line 2))))
 294       ;; Make a single line and parse that.
 295       (let ((buff (current-buffer)))
 296         (with-temp-buffer
 297           (insert-buffer-substring buff start end)
 298           (goto-char (point-min))
 299           (while (re-search-forward "^;+[ \t]+" nil t)
 300             (replace-match ""))
 301           (goto-char (point-min))
 302           (while (re-search-forward " *\n" nil t)
 303             (replace-match " "))
 304           (goto-char (point-min))
 305           (while (re-search-forward "\\([0-9]+\\),? +" nil t)
 306             (setq years (cons (match-string-no-properties 1) years)))
 307           (if (looking-at ".*$")
 308               (setq holder (match-string-no-properties 0)))))
 309       (cons holder (nreverse years)))))
 310
 311 (defun lm-summary (&optional file)
 312   "Return the one-line summary of file FILE, or current buffer if FILE is nil."
 313   (lm-with-file file
 314     (goto-char (point-min))
 315     (if (and (looking-at lm-header-prefix)
 316              (progn (goto-char (match-end 0))
 317                     (looking-at "[^ ]+[ \t]+--+[ \t]+\\(.*\\)")))
 318         (let ((summary (match-string-no-properties 1)))
 319           ;; Strip off -*- specifications.
 320           (if (string-match "[ \t]*-\\*-.*-\\*-" summary)
 321               (substring summary 0 (match-beginning 0))
 322             summary)))))
 323
 324 (defun lm-crack-address (x)
 325   "Split up an email address X into full name and real email address.
 326 The value is a cons of the form (FULLNAME . ADDRESS)."
 327   (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
 328          (cons (match-string 1 x)
 329                (match-string 2 x)))
 330         ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
 331          (cons (match-string 2 x)
 332                (match-string 1 x)))
 333         ((string-match "\\S-+@\\S-+" x)
 334          (cons nil x))
 335         (t
 336          (cons x nil))))
 337
 338 (defun lm-authors (&optional file)
 339   "Return the author list of file FILE, or current buffer if FILE is nil.
 340 Each element of the list is a cons; the car is the full name,
 341 the cdr is an email address."
 342   (lm-with-file file
 343     (let ((authorlist (lm-header-multiline "author")))
 344       (mapcar 'lm-crack-address authorlist))))
 345
 346 (defun lm-maintainer (&optional file)
 347   "Return the maintainer of file FILE, or current buffer if FILE is nil.
 348 The return value has the form (NAME . ADDRESS)."
 349   (lm-with-file file
 350     (let ((maint (lm-header "maintainer")))
 351       (if maint
 352           (lm-crack-address maint)
 353         (car (lm-authors))))))
 354
 355 (defun lm-creation-date (&optional file)
 356   "Return the created date given in file FILE, or current buffer if FILE is nil."
 357   (lm-with-file file
 358     (lm-header "created")))
 359
 360 (defun lm-last-modified-date (&optional file iso-date)
 361   "Return the modify-date given in file FILE, or current buffer if FILE is nil.
 362 ISO-DATE non-nil means return the date in ISO 8601 format."
 363   (lm-with-file file
 364     (when (progn (goto-char (point-min))
 365                  (re-search-forward
 366                   "\\$[I]d: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
 367                   (lm-code-mark) t))
 368       (let ((dd (match-string 3))
 369             (mm (match-string 2))
 370             (yyyy (match-string 1)))
 371         (if iso-date
 372             (format "%s-%s-%s" yyyy mm dd)
 373           (format "%s %s %s"
 374                   dd
 375                   (nth (string-to-int mm)
 376                        '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 377                          "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 378                   yyyy))))))
 379
 380 (defun lm-version (&optional file)
 381   "Return the version listed in file FILE, or current buffer if FILE is nil.
 382 This can be found in an RCS or SCCS header."
 383   (lm-with-file file
 384     (or (lm-header "version")
 385         (let ((header-max (lm-code-mark)))
 386           (goto-char (point-min))
 387           (cond
 388            ;; Look for an RCS header
 389            ((re-search-forward "\\$[I]d: [^ ]+ \\([^ ]+\\) " header-max t)
 390             (match-string-no-properties 1))
 391            ((re-search-forward "\\$Revision: +\\([^ ]+\\) " header-max t)
 392             (match-string-no-properties 1))
 393            ;; Look for an SCCS header
 394            ((re-search-forward
 395              (concat
 396               (regexp-quote "@(#)")
 397               (regexp-quote (file-name-nondirectory (buffer-file-name)))
 398               "\t\\([012345679.]*\\)")
 399              header-max t)
 400             (match-string-no-properties 1)))))))
 401
 402 (defun lm-keywords (&optional file)
 403   "Return the keywords given in file FILE, or current buffer if FILE is nil."
 404   (lm-with-file file
 405     (let ((keywords (lm-header "keywords")))
 406       (and keywords (downcase keywords)))))
 407
 408 (defun lm-keywords-list (&optional file)
 409   "Return list of keywords given in file FILE."
 410   (let ((keywords (lm-keywords file)))
 411     (if keywords
 412         (split-string keywords ",?[ \t]"))))
 413
 414 (defun lm-keywords-finder-p (&optional file)
 415   "Return non-nil if any keywords in FILE are known to finder."
 416   (require 'finder)
 417   (let ((keys (lm-keywords-list file)))
 418     (catch 'keyword-found
 419       (while keys
 420         (if (assoc (intern (car keys)) finder-known-keywords)
 421             (throw 'keyword-found t))
 422         (setq keys (cdr keys)))
 423       nil)))
 424
 425 (defun lm-adapted-by (&optional file)
 426   "Return the adapted-by names in file FILE, or current buffer if FILE is nil.
 427 This is the name of the person who cleaned up this package for
 428 distribution."
 429   (lm-with-file file
 430     (lm-header "adapted-by")))
 431
 432 (defun lm-commentary (&optional file)
 433   "Return the commentary in file FILE, or current buffer if FILE is nil.
 434 The value is returned as a string.  In the file, the commentary starts
 435 with the tag `Commentary' or `Documentation' and ends with one of the
 436 tags `Code', `Change Log' or `History'."
 437   (lm-with-file file
 438     (let ((commentary (lm-commentary-mark))
 439           (change-log (lm-history-mark))
 440           (code (lm-code-mark)))
 441       (cond
 442        ((and commentary change-log)
 443         (buffer-substring-no-properties commentary change-log))
 444        ((and commentary code)
 445         (buffer-substring-no-properties commentary code))))))
 446
 447 ;;; Verification and synopses
 448
 449 (defun lm-insert-at-column (col &rest strings)
 450   "Insert, at column COL, list of STRINGS."
 451   (if (> (current-column) col) (insert "\n"))
 452   (move-to-column col t)
 453   (apply 'insert strings))
 454
 455 (defun lm-verify (&optional file showok verbose non-fsf-ok)
 456   "Check that the current buffer (or FILE if given) is in proper format.
 457 If FILE is a directory, recurse on its files and generate a report in a
 458 temporary buffer.  In that case, the optional argument SHOWOK
 459 says display \"OK\" in temp buffer for files that have no problems.
 460
 461 Optional argument VERBOSE specifies verbosity level.
 462 Optional argument NON-FSF-OK if non-nil means a non-FSF
 463 copyright notice is allowed."
 464   (interactive (list nil nil t))
 465   (let* ((ret (and verbose "Ok"))
 466          name)
 467     (if (and file (file-directory-p file))
 468         (setq ret
 469               (with-temp-buffer
 470                 (mapcar
 471                  (lambda (f)
 472                    (if (string-match ".*\\.el\\'" f)
 473                        (let ((status (lm-verify f)))
 474                          (insert f ":")
 475                          (if status
 476                              (lm-insert-at-column lm-comment-column status
 477                                                   "\n")
 478                            (if showok
 479                                (lm-insert-at-column lm-comment-column
 480                                                     "OK\n"))))))
 481                  (directory-files file))))
 482       (lm-with-file file
 483         (setq name (lm-get-package-name))
 484         (setq ret
 485               (cond
 486                ((null name)
 487                 (format "Package %s does not exist"))
 488                ((not (lm-authors))
 489                 "`Author:' tag missing")
 490                ((not (lm-maintainer))
 491                 "`Maintainer:' tag missing")
 492                ((not (lm-summary))
 493                 "Can't find the one-line summary description")
 494                ((not (lm-keywords))
 495                 "`Keywords:' tag missing")
 496                ((not (lm-keywords-finder-p))
 497                 "`Keywords:' has no valid finder keywords (see `finder-known-keywords')")
 498                ((not (lm-commentary-mark))
 499                 "Can't find a 'Commentary' section marker")
 500                ((not (lm-history-mark))
 501                 "Can't find a 'History' section marker")
 502                ((not (lm-code-mark))
 503                 "Can't find a 'Code' section marker")
 504                ((progn
 505                   (goto-char (point-max))
 506                   (not
 507                    (re-search-backward
 508                     (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$"
 509                             "\\|^;;;[ \t]+ End of file[ \t]+" name)
 510                     nil t)))
 511                 (format "Can't find the footer line"))
 512                ((not (and (lm-copyright-mark) (lm-crack-copyright)))
 513                 "Can't find a valid copyright notice")
 514                ((not (or non-fsf-ok
 515                          (string-match "Free Software Foundation"
 516                                        (car (lm-crack-copyright)))))
 517                 "Copyright holder is not the Free Software Foundation")
 518                (t
 519                 ret)))))
 520     (if verbose
 521         (message ret))
 522     ret))
 523
 524 (defun lm-synopsis (&optional file showall)
 525   "Generate a synopsis listing for the buffer or the given FILE if given.
 526 If FILE is a directory, recurse on its files and generate a report in
 527 a temporary buffer.  If SHOWALL is non-nil, also generate a line for files
 528 which do not include a recognizable synopsis."
 529   (interactive
 530    (list
 531     (read-file-name "Synopsis for (file or dir): ")))
 532
 533   (if (and file (file-directory-p file))
 534       (with-temp-buffer
 535         (mapcar
 536          (lambda (f)
 537            (if (string-match "\\.el\\'" f)
 538                (let ((syn (lm-synopsis f)))
 539                  (if syn
 540                      (progn
 541                        (insert f ":")
 542                        (lm-insert-at-column lm-comment-column syn "\n"))
 543                    (when showall
 544                      (insert f ":")
 545                      (lm-insert-at-column lm-comment-column "NA\n"))))))
 546          (directory-files file)))
 547     (save-excursion
 548       (if file
 549           (find-file file))
 550       (prog1
 551           (lm-summary)
 552         (if file
 553             (kill-buffer (current-buffer)))))))
 554
 555 (eval-when-compile (defvar report-emacs-bug-address))
 556
 557 (defun lm-report-bug (topic)
 558   "Report a bug in the package currently being visited to its maintainer.
 559 Prompts for bug subject TOPIC.  Leaves you in a mail buffer."
 560   (interactive "sBug Subject: ")
 561   (require 'emacsbug)
 562   (let ((package (lm-get-package-name))
 563         (addr (lm-maintainer))
 564         (version (lm-version)))
 565     (compose-mail (if addr
 566                       (concat (car addr) " <" (cdr addr) ">")
 567                     report-emacs-bug-address)
 568                   topic)
 569     (goto-char (point-max))
 570     (insert "\nIn " package)
 571     (if version
 572         (insert " version " version))
 573     (newline 2)
 574     (message
 575      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
 576
 577 (provide 'lisp-mnt)
 578
 579 ;;; lisp-mnt.el ends here