annotate lisp/emacs-lisp/lisp-mnt.el @ 1087:6c410cc87574

* ralloc.c (r_re_alloc): Instead of allocating a new bloc at the end of the heap, copying the data to it, and then freeing the original bloc, just expand the original block. This saves a copy and a call to sbrk, and also removes the large spike in memory allocation that would occur when resizing large buffers. And it's less code.

  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 <[e-mail]>
  6 ;; Maintainer: Eric S. Raymond <[e-mail]>
  7 ;; Created: 14 Jul 1992
  8 ;; Version: 1.2
  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 multible authors, they should be listed on continuation
 55 ;; lines led by ;;<TAB>, like this:
 56 ;; 
 57 ;; ;; Author: Ashwin Ram <[e-mail]>
 58 ;; ;;	Dave Sill <[e-mail]>
 59 ;; ;;	David Lawrence <[e-mail]>
 60 ;; ;;	Noah Friedman <[e-mail]>
 61 ;; ;;	Joe Wells <[e-mail]>
 62 ;; ;;	Dave Brennan <[e-mail]>
 63 ;; ;;	Eric Raymond <[e-mail]>
 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.  Not
 82 ;; needed if you have 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 
117 ;; These functions all parse the headers of the current buffer
118 
119 (defun lm-section-mark (hd)
120   ;; Return the buffer location of a given section start marker
121   (save-excursion
122     (let ((case-fold-search t))
123       (goto-char (point-min))
124       (if (re-search-forward (concat "^;;; " hd ":$") nil t)
125 	  (progn
126 	    (beginning-of-line)
127 	    (point))
128 	nil))))
129 
130 (defun lm-code-mark ()
131   ;; Return the buffer location of the code start marker
132   (lm-section-mark "Code"))
133 
134 (defun lm-header (hd)
135   ;; Return the contents of a named header
136     (goto-char (point-min))
137     (let ((case-fold-search t))
138       (if (re-search-forward
139 	   (concat "^;; " hd ": \\(.*\\)") (lm-code-mark) t)
140 	  (buffer-substring (match-beginning 1) (match-end 1))
141 	nil)))
142 
143 (defun lm-header-multiline (hd)
144   ;; Return the contents of a named header, with possible continuation lines.
145   ;; Note -- the returned value is a list of strings, one per line.
146   (save-excursion
147     (goto-char (point-min))
148     (let ((res (save-excursion (lm-header hd))))
149       (if res
150 	  (progn
151 	    (forward-line 1)
152 	    (setq res (list res))
153 	    (while (looking-at "^;;\t\\(.*\\)")
154 	      (setq res (cons (buffer-substring
155 			       (match-beginning 1)
156 			       (match-end 1))
157 			      res))
158 	      (forward-line 1))
159 	    ))
160       res)))
161 
162 ;; These give us smart access to the header fields and commentary
163 
164 (defun lm-summary (&optional file)
165   ;; Return the buffer's or FILE's one-line summary.
166   (save-excursion
167     (if file
168 	(find-file file))
169     (goto-char (point-min))
170     (prog1
171       (if (looking-at "^;;; [^ ]+ --- \\(.*\\)")
172 	  (buffer-substring (match-beginning 1) (match-end 1)))
173       (if file
174 	  (kill-buffer (current-buffer)))
175       )))
176 
177 (defun lm-authors (&optional file)
178   ;; Return the buffer's or FILE's author list.
179   (save-excursion
180     (if file
181 	(find-file file))
182     (prog1
183 	(lm-header-multiline "author")
184       (if file
185 	  (kill-buffer (current-buffer)))
186     )))
187 
188 (defun lm-maintainer (&optional file)
189   ;; Get a package's bug-report & maintenance address.  Parse it out of FILE,
190   ;; or the current buffer if FILE is nil.
191   ;; This may be a name-address pair, or an address by itself,
192   (save-excursion
193     (if file
194 	(find-file file))
195     (prog1
196 	(let ((raw-address
197 	       (or
198 		(save-excursion (lm-header "maintainer"))
199 		(car (lm-authors)))))
200 	  (cond	((string-match "[^<]<\\([^>]+\\)>" raw-address)
201 		 (substring raw-address  (match-beginning 1) (match-end 1)))
202 		(t raw-address))
203 	  )
204       (if file
205 	  (kill-buffer (current-buffer)))
206       )))
207 
208 (defun lm-creation-date (&optional file)
209   ;; Return a package's creation date, if any.  Parse it out of FILE,
210   ;; or the current buffer if FILE is nil.
211   (save-excursion
212     (if file
213 	(find-file file))
214     (prog1
215 	(lm-header "created")
216       (if file
217 	  (kill-buffer (current-buffer)))
218       )))
219 
220 
221 (defun lm-last-modified-date (&optional file)
222   ;; Return a package's last-modified date, if you can find one.
223   (save-excursion 
224     (if file
225 	(find-file file))
226     (prog1
227 	 (if (progn
228 	       (goto-char (point-min))
229 	       (re-search-forward
230 		"\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
231 		(lm-code-mark) t))
232 	     (format "%s %s %s"
233 		     (buffer-substring (match-beginning 3) (match-end 3))
234 		     (nth (string-to-int 
235 			   (buffer-substring (match-beginning 2) (match-end 2)))
236 			  '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
237 			    "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
238 		     (buffer-substring (match-beginning 1) (match-end 1))
239 		     )))
240       (if file
241 	  (kill-buffer (current-buffer)))
242       ))
243 
244 (defun lm-version (&optional file)
245   ;; Return the package's version field.
246   ;; If none, look for an RCS or SCCS header to crack it out of.
247   (save-excursion 
248     (if file
249 	(find-file file))
250     (prog1
251 	(or
252 	 (lm-header "version")
253 	 (let ((header-max (lm-code-mark)))
254 	   (goto-char (point-min))
255 	   (cond
256 	    ;; Look for an RCS header
257 	    ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t)
258 	     (buffer-substring (match-beginning 1) (match-end 1)))
259 
260 	    ;; Look for an SCCS header
261 	    ((re-search-forward 
262 	      (concat
263 	       (regexp-quote "@(#)")
264 	       (regexp-quote (file-name-nondirectory (buffer-file-name)))
265 	       "\t\\([012345679.]*\\)")
266 	      header-max t)
267 	     (buffer-substring (match-beginning 1) (match-end 1)))
268 
269 	    (t nil))))
270       (if file
271 	  (kill-buffer (current-buffer)))
272       )))
273 
274 (defun lm-keywords (&optional file)
275   ;; Return the header containing the package's topic keywords.
276   ;; Parse them out of FILE, or the current buffer if FILE is nil.
277   (save-excursion
278     (if file
279 	(find-file file))
280     (prog1
281 	(let ((keywords (lm-header "keywords")))
282 	  (and keywords (downcase keywords)))
283       (if file
284 	  (kill-buffer (current-buffer)))
285       )))
286 
287 (defun lm-adapted-by (&optional file)
288   ;; Return the name or code of the person who cleaned up this package
289   ;; for distribution.  Parse it out of FILE, or the current buffer if
290   ;; FILE is nil.
291   (save-excursion
292     (if file
293 	(find-file file))
294     (prog1
295 	(lm-header "adapted-by")
296       (if file
297 	  (kill-buffer (current-buffer)))
298       )))
299 
300 (defun lm-commentary-region (&optional file)
301   ;; Return a pair of character locations enclosing the commentary region.
302   (save-excursion
303     (if file
304 	(find-file file))
305     (prog1
306 	(let ((commentary (lm-section-mark "Commentary"))
307 	      (change-log (lm-section-mark "Change Log"))
308 	      (code (lm-section-mark "Code")))
309 	  (if commentary
310 	      (if change-log
311 		  (cons commentary change-log)
312 		(cons commentary code)))
313 	  )
314       (if file
315 	  (kill-buffer (current-buffer)))
316       )))
317 
318 ;;; Verification and synopses
319 
320 (defun insert-at-column (col &rest pieces)
321    (if (> (current-column) col) (insert "\n"))
322    (move-to-column-force col)
323    (apply 'insert pieces))
324 
325 (defconst lm-comment-column 16)
326 
327 (defun lm-verify (&optional file showok)
328   "Check that the current buffer (or FILE if given) is in proper format.
329 If FILE is a directory, recurse on its files and generate a report into
330 a temporary buffer."
331   (if (and file (file-directory-p file))
332       (progn
333 	(switch-to-buffer (get-buffer-create "*lm-verify*"))
334 	(erase-buffer)
335 	(mapcar
336 	 '(lambda (f)
337 	    (if (string-match ".*\\.el$" f)
338 		(let ((status (lm-verify f)))
339 		  (if status
340 		      (progn
341 			(insert f ":")
342 			(insert-at-column lm-comment-column status "\n"))
343 		    (and showok
344 			 (progn
345 			   (insert f ":")
346 			   (insert-at-column lm-comment-column "OK\n")))))))
347 	(directory-files file))
348     )
349   (save-excursion
350     (if file
351 	(find-file file))
352     (prog1
353 	(cond
354 	 ((not (lm-summary))
355 	  "Can't find a package summary")
356 	 ((not (lm-code-mark))
357 	  "Can't find a code section marker")
358 	 ((progn
359 	    (goto-char (point-max))
360 	    (forward-line -1)
361 	    (looking-at (concat ";;; " file "ends here")))
362 	  "Can't find a footer line")
363 	 )
364       (if file
365 	  (kill-buffer (current-buffer)))
366       ))))
367 
368 (defun lm-synopsis (&optional file showall)
369   "Generate a synopsis listing for the buffer or the given FILE if given.
370 If FILE is a directory, recurse on its files and generate a report into
371 a temporary buffer.  If SHOWALL is on, also generate a line for files
372 which do not include a recognizable synopsis."
373   (if (and file (file-directory-p file))
374       (progn
375 	(switch-to-buffer (get-buffer-create "*lm-verify*"))
376 	(erase-buffer)
377 	(mapcar
378 	 '(lambda (f)
379 	    (if (string-match ".*\\.el$" f)
380 		(let ((syn (lm-synopsis f)))
381 		  (if syn
382 		      (progn
383 			(insert f ":")
384 			(insert-at-column lm-comment-column syn "\n"))
385 		    (and showall
386 			 (progn
387 			   (insert f ":")
388 			   (insert-at-column lm-comment-column "NA\n")))))))
389 	 (directory-files file))
390 	)
391     (save-excursion
392       (if file
393 	  (find-file file))
394       (prog1
395 	  (lm-summary)
396 	(if file
397 	    (kill-buffer (current-buffer)))
398 	))))
399 
400 (defun lm-report-bug (topic)
401   "Report a bug in the package currently being visited to its maintainer.
402 Prompts for bug subject.  Leaves you in a mail buffer."
403   (let ((package (buffer-name))
404 	(addr (lm-maintainer))
405 	(version (lm-version)))
406     ;; We do this in order to avoid duplicating the general bug address here
407     (if (or (not addr) (string= "FSF"))
408 	(progn
409 	  (load-library "emacsbug.el")
410 	  (emacsbug (format "%s --- %s" package topic))))
411     (interactive "sBug Subject: ")
412     (mail nil addr topic)
413     (goto-char (point-max))
414     (insert "\nIn "
415 	    package
416 	    (and version (concat " version " version))
417 	    "\n\n")
418     (message
419      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
420 
421 (provide 'lisp-mnt)
422 
423 ;;; lisp-mnt.el ends here