diff lisp/emacs-lisp/lisp-mnt.el @ 88155:d7ddb3e565de

sync with trunk

--- a/lisp/emacs-lisp/lisp-mnt.el	Sun Jan 15 23:02:10 2006 +0000
+++ b/lisp/emacs-lisp/lisp-mnt.el	Mon Jan 16 00:03:54 2006 +0000
@@ -1,6 +1,7 @@
-;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers
+;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers
 
-;; Copyright (C) 1992, 1994, 1997, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 1997, 2000, 2001, 2002, 2003, 2004,
+;;   2005 Free Software Foundation, Inc.
 
 ;; Author: Eric S. Raymond <[e-mail]>
 ;; Maintainer: FSF
@@ -22,12 +23,12 @@
 
 ;; 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,  Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; the Free Software Foundation,  Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
-;; This minor mode adds some services to Emacs-Lisp editing mode.
+;; This library 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.
@@ -79,7 +80,7 @@
 ;; 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
+;; 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
@@ -124,7 +125,7 @@
 ;;; Variables:
 
 (defgroup lisp-mnt nil
-  "Minor mode for Emacs Lisp maintainers."
+  "Utility functions for Emacs Lisp maintainers."
   :prefix "lm-"
   :group 'maint)
 
@@ -156,6 +157,11 @@
   :type 'integer
   :group 'lisp-mnt)
 
+(defcustom lm-any-header ".*"
+  "Regexp which matches start of any section."
+  :type 'regexp
+  :group 'lisp-mnt)
+
 (defcustom lm-commentary-header "Commentary\\|Documentation"
   "Regexp which matches start of documentation section."
   :type 'regexp
@@ -175,8 +181,8 @@
 If called with optional MODE and with value `section',
 return section regexp instead."
   (if (eq mode 'section)
-      (concat "^;;;;* " header ":[ \t]*$")
-    (concat lm-header-prefix header "[ \t]*:[ \t]*")))
+      (concat "^;;;;* \\(" header "\\):[ \t]*$")
+    (concat lm-header-prefix "\\(" header "\\)[ \t]*:[ \t]*")))
 
 (defun lm-get-package-name ()
   "Return package name by looking at the first line."
@@ -188,30 +194,66 @@
 		    (match-end 1)))
 	(match-string-no-properties 1))))
 
-(defun lm-section-mark (header &optional after)
+(defun lm-section-start (header &optional after)
   "Return the buffer location of a given section start marker.
 The HEADER is the section mark string to search for.
-If AFTER is non-nil, return the location of the next line."
+If AFTER is non-nil, return the location of the next line.
+If the given section does not exist, return nil."
   (save-excursion
     (let ((case-fold-search t))
       (goto-char (point-min))
       (if (re-search-forward (lm-get-header-re header 'section) nil t)
-	  (progn
-	    (beginning-of-line)
-	    (if after (forward-line 1))
-	    (point))))))
+          (line-beginning-position (if after 2))))))
+(defalias 'lm-section-mark 'lm-section-start)
+
+(defun lm-section-end (header)
+  "Return the buffer location of the end of a given section.
+The HEADER is the section string marking the beginning of the
+section.  If the given section does not exist, return nil.
 
-(defsubst lm-code-mark ()
+The end of the section is defined as the beginning of the next
+section of the same level or lower.  The function
+`lisp-outline-level' is used to compute the level of a section.
+If no such section exists, return the end of the buffer."
+  (require 'outline)   ;; for outline-regexp.
+  (let ((start (lm-section-start header)))
+    (when start
+      (save-excursion
+        (goto-char start)
+        (let ((level (lisp-outline-level))
+              (case-fold-search t)
+              next-section-found)
+          (beginning-of-line 2)
+          (while (and (setq next-section-found
+                            (re-search-forward
+                             (lm-get-header-re lm-any-header 'section)
+                             nil t))
+                      (> (save-excursion
+                           (beginning-of-line)
+                           (lisp-outline-level))
+                         level)))
+          (if next-section-found
+              (line-beginning-position)
+            (point-max)))))))
+
+(defsubst lm-code-start ()
   "Return the buffer location of the `Code' start marker."
-  (lm-section-mark "Code"))
+  (lm-section-start "Code"))
+(defalias 'lm-code-mark 'lm-code-start)
 
-(defsubst lm-commentary-mark ()
+(defsubst lm-commentary-start ()
   "Return the buffer location of the `Commentary' start marker."
-  (lm-section-mark lm-commentary-header))
+  (lm-section-start lm-commentary-header))
+(defalias 'lm-commentary-mark 'lm-commentary-start)
 
-(defsubst lm-history-mark ()
+(defsubst lm-commentary-end ()
+  "Return the buffer location of the `Commentary' section end."
+  (lm-section-end lm-commentary-header))
+
+(defsubst lm-history-start ()
   "Return the buffer location of the `History' start marker."
-  (lm-section-mark lm-history-header))
+  (lm-section-start lm-history-header))
+(defalias 'lm-history-mark 'lm-history-start)
 
 (defsubst lm-copyright-mark ()
   "Return the buffer location of the `Copyright' line."
@@ -219,8 +261,7 @@
     (let ((case-fold-search t))
       (goto-char (point-min))
       (if (re-search-forward lm-copyright-prefix nil t)
-	  (point))))
-  )
+	  (point)))))
 
 (defun lm-header (header)
   "Return the contents of the header named HEADER."
@@ -257,15 +298,21 @@
 ;; These give us smart access to the header fields and commentary
 
 (defmacro lm-with-file (file &rest body)
-  "Make a buffer with FILE current, and execute BODY.
-If FILE isn't in a buffer, load it in, and kill it after BODY is executed."
+  "Execute BODY in a buffer containing the contents of FILE.
+If FILE is nil, execute BODY in the current buffer."
   (let ((filesym (make-symbol "file")))
-    `(save-excursion
-       (let ((,filesym ,file))
-	 (if ,filesym (set-buffer (find-file-noselect ,filesym)))
-	 (prog1 (progn ,@body)
-	   (if (and ,filesym (not (get-buffer-window (current-buffer) t)))
-	       (kill-buffer (current-buffer))))))))
+    `(let ((,filesym ,file))
+       (if ,filesym
+	   (with-temp-buffer
+	     (insert-file-contents ,filesym)
+	     (lisp-mode)
+	     ,@body)
+	 (save-excursion
+	   ;; Switching major modes is too drastic, so just switch
+	   ;; temporarily to the Lisp mode syntax table.
+	   (with-syntax-table lisp-mode-syntax-table
+	     ,@body))))))
+
 (put 'lm-with-file 'lisp-indent-function 1)
 (put 'lm-with-file 'edebug-form-spec t)
 
@@ -372,7 +419,7 @@
 	    (format "%s-%s-%s" yyyy mm dd)
 	  (format "%s %s %s"
 		  dd
-		  (nth (string-to-int mm)
+		  (nth (string-to-number mm)
 		       '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
 			 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 		  yyyy))))))
@@ -411,6 +458,7 @@
     (if keywords
 	(split-string keywords ",?[ \t]"))))
 
+(defvar finder-known-keywords)
 (defun lm-keywords-finder-p (&optional file)
   "Return non-nil if any keywords in FILE are known to finder."
   (require 'finder)
@@ -431,18 +479,14 @@
 
 (defun lm-commentary (&optional file)
   "Return the commentary in file FILE, or current buffer if FILE is nil.
-The value is returned as a string.  In the file, the commentary starts
-with the tag `Commentary' or `Documentation' and ends with one of the
-tags `Code', `Change Log' or `History'."
+Return the value as a string.  In the file, the commentary
+section starts with the tag `Commentary' or `Documentation' and
+ends just before the next section.  If the commentary section is
+absent, return nil."
   (lm-with-file file
-    (let ((commentary (lm-commentary-mark))
-	  (change-log (lm-history-mark))
-	  (code (lm-code-mark)))
-      (cond
-       ((and commentary change-log)
-	(buffer-substring-no-properties commentary change-log))
-       ((and commentary code)
-	(buffer-substring-no-properties commentary code))))))
+    (let ((start (lm-commentary-start)))
+      (when start
+        (buffer-substring-no-properties start (lm-commentary-end))))))
 
 ;;; Verification and synopses
 
@@ -484,7 +528,7 @@
 	(setq ret
 	      (cond
 	       ((null name)
-		(format "Package %s does not exist"))
+		"Can't find package name")
 	       ((not (lm-authors))
 		"`Author:' tag missing")
 	       ((not (lm-maintainer))
@@ -508,7 +552,7 @@
 		    (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$"
 			    "\\|^;;;[ \t]+ End of file[ \t]+" name)
 		    nil t)))
-		(format "Can't find the footer line"))
+		"Can't find the footer line")
 	       ((not (and (lm-copyright-mark) (lm-crack-copyright)))
 		"Can't find a valid copyright notice")
 	       ((not (or non-fsf-ok
@@ -531,26 +575,21 @@
     (read-file-name "Synopsis for (file or dir): ")))
 
   (if (and file (file-directory-p file))
-      (with-temp-buffer
-	(mapcar
-	 (lambda (f)
-	   (if (string-match "\\.el\\'" f)
-	       (let ((syn (lm-synopsis f)))
-		 (if syn
-		     (progn
-		       (insert f ":")
-		       (lm-insert-at-column lm-comment-column syn "\n"))
-		   (when showall
-		     (insert f ":")
-		     (lm-insert-at-column lm-comment-column "NA\n"))))))
-	 (directory-files file)))
+      (with-output-to-temp-buffer "*Synopsis*"
+        (set-buffer standard-output)
+        (dolist (f (directory-files file nil ".*\\.el\\'"))
+          (let ((syn (lm-synopsis (expand-file-name f file))))
+            (when (or syn showall)
+              (insert f ":")
+              (lm-insert-at-column lm-comment-column (or syn "NA") "\n")))))
     (save-excursion
-      (if file
-	  (find-file file))
-      (prog1
-	  (lm-summary)
-	(if file
-	    (kill-buffer (current-buffer)))))))
+      (let ((must-kill (and file (not (get-file-buffer file)))))
+        (when file (find-file file))
+        (prog1
+            (if (interactive-p)
+                (message "%s" (lm-summary))
+              (lm-summary))
+          (when must-kill (kill-buffer (current-buffer))))))))
 
 (eval-when-compile (defvar report-emacs-bug-address))
 
@@ -571,9 +610,10 @@
     (if version
 	(insert " version " version))
     (newline 2)
-    (message
+    (message "%s"
      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
 
 (provide 'lisp-mnt)
 
+;;; arch-tag: fa3c5ab4-a37b-4e46-b7cf-b6d78b90e69e
 ;;; lisp-mnt.el ends here