home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / sccs-comment.el < prev    next >
Encoding:
Text File  |  1993-02-28  |  7.1 KB  |  182 lines
  1. ; From: kevin@traffic.den.mmc.com (Kevin Rodgers)
  2. ; Subject: GNU Elisp Archive submission: sccs-comment.el
  3. ; Date: Mon, 1 Mar 93 09:10:59 MST
  4. ; 
  5. ; 
  6. ; >Newsgroups: gnu.emacs.sources
  7. ; >Path: news.den.mmc.com!csn!magnus.acs.ohio-state.edu!zaphod.mps.ohio-state.edu!howland.reston.ans.net!europa.eng.gtefsd.com!uunet!ulowell!das.wang.com!wang!tegra!vail
  8. ; >From: vail@tegra.com (Johnathan Vail)
  9. ; >Subject: sccs-comment.el Release
  10. ; >Message-ID: <C3310x.3HF@tegra.com>
  11. ; >Organization: Tegra-Varityper, Inc. Billerica, MA
  12. ; >Date: Sat, 27 Feb 1993 00:50:56 GMT
  13. ; >Lines: 169
  14. ; >
  15. ; >This is the sccs comment string editing package written by Kevin
  16. ; >Rodgers.  It is an option added to the previosly posted sccs.el
  17. ; >package.
  18. ; >
  19. ; >
  20. ; >happy hacking, jv
  21. ; >
  22. ; > _____
  23. ; >|     | Johnathan Vail     vail@tegra.com     (508) 663-7435
  24. ; >|Tegra| jv@n1dxg.ampr.org    N1DXG@448.625-(WorldNet)
  25. ; > -----  MEMBER: League for Programming Freedom (league@prep.ai.mit.edu)
  26. ; 
  27. ;;;;    sccs-comment.el
  28. ;;;;
  29. ;;;;    Define sccs-edit-comment, which pops up a buffer for editing an
  30. ;;;;    'SCCS' delta comment, then returns the buffer's contents as a
  31. ;;;;    string.  This for use with sccs.el (written by Jonathan Vail)
  32. ;;;;    version 2.0, by providing a suitable functional value for
  33. ;;;;    sccs-delta-comments.
  34. ;;;;
  35. ;;;;    Copyright (C) 1993 Kevin Rodgers
  36. ;;;;
  37. ;;;;    This program is free software; you can redistribute it and/or modify
  38. ;;;;    it under the terms of the GNU General Public License as published by
  39. ;;;;    the Free Software Foundation; either version 1, or (at your option)
  40. ;;;;    any later version.
  41. ;;;;
  42. ;;;;    This program is distributed in the hope that it will be useful,
  43. ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
  44. ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  45. ;;;;    GNU General Public License for more details.
  46. ;;;;
  47. ;;;;    You should have received a copy of the GNU General Public License
  48. ;;;;    along with this program; if not, write to the Free Software
  49. ;;;;    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  50. ;;;;
  51. ;;;;    Martin Marietta has not disclaimed any copyright interest in
  52. ;;;;    sccs-comment.el.
  53. ;;;;
  54. ;;;;    Kevin Rodgers                kevin@traffic.den.mmc.com
  55. ;;;;    Martin Marietta MS A16401        (303) 790-3971
  56. ;;;;    116 Inverness Dr. East
  57. ;;;;    Englewood CO 80112 USA
  58. ;;;;
  59. ;;;;    Installation:
  60. ;;;;    1. Put this file in a directory that is a member of load-path, and
  61. ;;;;       byte-compile it for better performance.
  62. ;;;;    2. Put these forms in ~/.emacs:
  63. ;;;;       (setq sccs-delta-comments (function sccs-edit-comment))
  64. ;;;;       (autoload 'sccs-edit-comment "sccs-edit-comment"
  65. ;;;;             "Pop up a buffer for editing an 'SCCS' delta comment...")
  66. ;;;;
  67. ;;;;    Usage:
  68. ;;;;    See sccs.el first: sccs-edit-comment is invoked via sccs-delget
  69. ;;;;    and sccs-deledit.
  70. ;;;;
  71. ;;;;    You may want to set the sccs-edit-comment-hooks variable; for
  72. ;;;;    example: (setq sccs-edit-comment-hooks (function text-mode))
  73. ;;;;
  74. ;;;;    LCD Archive Entry:
  75. ;;;;    sccs-comment|Kevin Rodgers|kevin@traffic.den.mmc.com|
  76. ;;;;    sccs-delta-comments customization for sccs.el 2.0.|
  77. ;;;;    1993-02-23|1.0|~/misc/sccs-comment.el.Z|
  78.  
  79. (require 'sccs)
  80.  
  81. (defvar sccs-comment-buffer-name "*Comment*"
  82.   "The name of the buffer used by sccs-edit-comment.")
  83.  
  84. (defvar sccs-edit-comment-hooks nil
  85.   "The hook variable used by sccs-edit-comment.")
  86.  
  87. (defun sccs-edit-comment ()
  88.   "Pop up a buffer for editing an 'SCCS' delta comment, and return the
  89. buffer contents as a string.  The hook variable edit-comment-hooks is
  90. run after the buffer is created.
  91.  
  92. This function invokes a recursive edit, which is exited by sccs-exit-
  93. edit-comment; it is intended for use as a value of sccs-delta-comments
  94. \(which see\)."
  95.   (save-excursion
  96.     (save-window-excursion
  97.       (pop-to-buffer (get-buffer-create sccs-comment-buffer-name))
  98.       (widen)
  99.       (erase-buffer)
  100.       (run-hooks 'sccs-edit-comment-hooks)
  101.       (unwind-protect            ; restore exit-recursive-edit keybinding
  102.       (catch 'sccs-edit-comment    ; catch and return comment
  103.         (sccs:substitute-key-definition (function exit-recursive-edit)
  104.                         (function sccs-exit-edit-comment)
  105.                         (current-global-map)
  106.                         t)
  107.         (message "Type %s to return the contents of the '%s' buffer, or %s to abort"
  108.              (substitute-command-keys "\\[sccs-exit-edit-comment]")
  109.              sccs-comment-buffer-name
  110.              (substitute-command-keys "\\[abort-recursive-edit]"))
  111.         (recursive-edit)
  112.         ;; In case exit-recursive-edit was explicitly invoked:
  113.         (error "Recursive edit of '%s' buffer exited without returning \
  114. comment string"
  115.            sccs-comment-buffer-name))
  116.     (sccs:substitute-key-definition (function sccs-exit-edit-comment)
  117.                     (function exit-recursive-edit)
  118.                     (current-global-map)
  119.                     t)))))
  120.       
  121. (defun sccs-exit-edit-comment ()
  122.   "*Return the contents of the sccs-comment-buffer-name buffer to sccs-
  123. edit-comment."
  124.   (interactive)
  125.   (let ((sccs-comment-buffer (get-buffer sccs-comment-buffer-name)))
  126.     (if (and (or sccs-comment-buffer
  127.          (error "'%s' buffer does not exist" sccs-comment-buffer-name))
  128.          (or (> (recursion-depth) 0)
  129.          (error "No recursive edit is in progress")))
  130.     (save-excursion
  131.       (set-buffer sccs-comment-buffer)
  132.       (let ((comment (buffer-string)))
  133.         (set-buffer-modified-p nil)
  134.         ;; (bury-buffer)        ; not necessary, since catch is
  135.                     ; protected by save-window-excursion
  136.         (throw 'sccs-edit-comment comment)))))) ; exits recursive-edit, too
  137.  
  138.  
  139. ;; Define sccs:substitute-key-definition (compatible with substitute-
  140. ;; key-definition):
  141.  
  142. (defun sccs:substitute-key-definition (olddef newdef keymap &optional recur)
  143.   "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
  144. In other words, OLDDEF is replaced with NEWDEF where ever it appears.
  145.  
  146. If the optional argument RECUR is non-nil, also recursively substitute
  147. NEWDEF for OLDEF in keymaps accessible from KEYMAP via a non-empty
  148. prefix key.  If RECUR is t, do so for all accessible keymaps; otherwise,
  149. it should be a predicate \(i.e. a function of one argument\) which is
  150. applied to each accessible keymap to determine \(according to whether
  151. the result is non-nil\) whether the substitution will be performed in it."
  152. (if (keymapp keymap)
  153.     (progn
  154.       (cond ((and (vectorp keymap) (= (length keymap) 128))
  155.          (let ((i 0))
  156.            (while (< i 128)
  157.          (if (eq (aref keymap i) olddef)
  158.              (aset keymap i newdef))
  159.          (setq i (1+ i)))))
  160.         ((and (consp keymap) (eq (car keymap) 'keymap))
  161.          (let ((key-defs (cdr keymap)))
  162.            (while key-defs
  163.          (if (eq (cdr-safe (car-safe key-defs)) olddef)
  164.              (setcdr (car key-defs) newdef))
  165.          (setq key-defs (cdr key-defs))))))
  166.       (if recur
  167.       ;; accessible-keymaps returns all keymaps recursively
  168.       ;; accessible from its argument keymap, so the recursive call
  169.       ;; to sccs:substitute-key-definition should disable any further
  170.       ;; recursion by explicitly passing nil as the fourth argument.
  171.       (let ((sub-keymap-alist (cdr (accessible-keymaps keymap))))
  172.         (while sub-keymap-alist
  173.           (if (or (eq recur t)
  174.               (funcall recur (cdr (car sub-keymap-alist))))
  175.           (sccs:substitute-key-definition olddef newdef
  176.                           (cdr (car sub-keymap-alist))
  177.                           nil))
  178.           (setq sub-keymap-alist (cdr sub-keymap-alist))))))))
  179.  
  180.  
  181.  
  182.