home *** CD-ROM | disk | FTP | other *** search
/ The CDPD Public Domain Collection for CDTV 3 / CDPDIII.bin / pd / programming / gnusmalltalk / st-changelog.el < prev    next >
Lisp/Scheme  |  1991-11-09  |  6KB  |  190 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;
  4. ;;; Change log support routines for Smalltalk.
  5. ;;;
  6. ;;; Steve Byrne, February 1989.
  7. ;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ;;;
  13. ;;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
  14. ;;; Written by Steve Byrne.
  15. ;;; 
  16. ;;; This file is part of GNU Smalltalk.
  17. ;;;  
  18. ;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
  19. ;;; under the terms of the GNU General Public License as published by the Free
  20. ;;; Software Foundation; either version 1, or (at your option) any later 
  21. ;;; version.
  22. ;;;
  23. ;;; GNU Smalltalk is distributed in the hope that it will be useful, but
  24. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  25. ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  26. ;;; for more details.
  27. ;;;
  28. ;;; You should have received a copy of the GNU General Public License along
  29. ;;; with GNU Smalltalk; see the file COPYING.  If not, write to the Free
  30. ;;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  31. ;;;
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33.  
  34. (defconst smalltalk-date-column 13)
  35. (defconst smalltalk-change-column 26)
  36.  
  37. (defun smalltalk-create-change-log (&optional position-ok)
  38.   "Inserts a changelog template into the current buffer.
  39. Only Smalltalk style changelogs are supported right now."
  40.   (interactive)
  41.   (if (not position-ok)
  42.       (progn
  43.     (message "Move the cursor to where the change log should be, then C-c C-c ")
  44.     (let ((old-cc (key-binding "\C-c\C-c")))
  45.       (unwind-protect
  46.           (progn 
  47.         (local-set-key "\C-c\C-c" 'exit-recursive-edit)
  48.         (recursive-edit))
  49.         (local-set-key "\C-c\C-c" old-cc)))
  50.     (beginning-of-line)
  51.     ))
  52.   (insert-string
  53. "\"
  54. |     Change Log
  55. | ============================================================================
  56. | Author       Date       Change 
  57. \"
  58. ")
  59.   )
  60.  
  61. (defun smalltalk-add-change-log-entry ()
  62.   "Allows the user to add a change log entry to the current
  63. buffer.  If there is no change log currently present, the user is informed 
  64. of this fact, and is allowed to position the cursor where the change log
  65. should be placed."
  66.   (interactive)
  67.   (save-excursion
  68.     (while (not (smalltalk-find-change-log))
  69.       (message "Change log not found") (sit-for 5)
  70.       (smalltalk-create-change-log)
  71.     )
  72.     (smalltalk-add-change-log-mode)
  73.     ))
  74.  
  75.  
  76.  
  77. (defun smalltalk-install-change-log-functions ()
  78.   "Adds the change log functions to the current set of character bindings."
  79.   (define-key smalltalk-mode-map "\C-c\C-c" 'smalltalk-add-change-log-entry)
  80.   (define-key smalltalk-mode-map "\C-cC" 'smalltalk-create-change-log)
  81.   )
  82.  
  83. (defun smalltalk-find-change-log ()
  84.   "Locates the buffer's change log and positions the cursor where the next
  85. entry should appear.  Returns non-nil if the changelog is found, and nil if
  86. it isn't found."
  87.   (beginning-of-buffer)
  88.   (if (re-search-forward "^\|     Change Log" nil t)
  89.       (progn
  90.     (forward-line 3)
  91.     t))
  92.   )
  93.  
  94. (defun smalltalk-add-change-log-mode ()
  95.   "Go into add change log mode."
  96.   (let ((old-return (key-binding "\r"))
  97.     (old-newline (key-binding "\n"))
  98.     (old-^c^c (key-binding "\C-c\C-c"))
  99.     (mode-name mode-name)
  100.     (indent-line-function 'smalltalk-changelog-mode-indent)
  101.     (fill-prefix nil)
  102.     (fill-column 79)
  103.     (auto-fill-hook 'do-auto-fill))
  104.     (unwind-protect
  105.     (progn 
  106.       (local-set-key "\r" 'newline-and-indent)
  107.       (local-set-key "\n" 'newline-and-indent)
  108.       (local-set-key "\C-c\C-c" 'exit-recursive-edit)
  109.       (setq mode-name "Changelog")
  110.       (smalltalk-init-change-log-entry)
  111.       (save-excursion
  112.         (recursive-edit))
  113.       (smalltalk-clean-up-after-changing)
  114.       )
  115.       (local-set-key "\r" old-return)
  116.       (local-set-key "\n" old-newline)
  117.       (local-set-key "\C-c\C-c" old-^c^c)
  118.       )
  119.     ))
  120.  
  121. (defun smalltalk-init-change-log-entry ()
  122.   "Inserts the initial change log entry stuff, which
  123. is the user name and the date."
  124.   (insert-string "| " (user-login-name))
  125.   (indent-to smalltalk-date-column)
  126.   (insert-string (string-date))
  127.   (indent-to smalltalk-change-column)
  128.   (save-excursion
  129.     (insert-string "\n|\n")
  130.     )
  131.   )
  132.  
  133.  
  134. (defun string-date ()
  135.   "Returns a string date of the form dd mmm yy for the
  136. current date."
  137.   (let ((now (current-time-string)))
  138.     (concat
  139.      (substring now 8 10)            ;the day
  140.      " "
  141.      (substring now 4 7)            ;the month
  142.      " "
  143.      (substring now 22 24)        ;the year
  144.      )))
  145.  
  146. (defun smalltalk-changelog-mode-indent ()
  147.   "Insert the comment continuation character, and tab to the change log
  148. text column."
  149.   (interactive)
  150.   (insert-string "|")
  151.   (indent-to smalltalk-change-column))
  152.  
  153. ;;; Yuck... I don't like the way I wrote this...I'll bet there is
  154. ;;; a cleaner way...
  155.  
  156. (defun smalltalk-clean-up-after-changing ()
  157.   "Performs cleanup operations such as deleting extraneous blank lines
  158. at the end of a change log entry.  Point is at the start of the text
  159. for the current change log entry."
  160.   (let (dot (num-blanks 0))
  161.     (while (not (smalltalk-line-is-blank))
  162.       (forward-line))
  163.     (setq dot (point))
  164.     (beginning-of-line)
  165.     (if (< (point) dot)            ;our first blank line is the
  166.                     ;change log line, so fake
  167.                     ;an extra line to be removed
  168.     (setq num-blanks 1))
  169.     (setq dot (point))
  170.     (while (smalltalk-line-is-blank t)
  171.       (setq num-blanks (1+ num-blanks))
  172.       (forward-line))
  173.     (if (> num-blanks 1)
  174.     (progn
  175.       (goto-char dot)
  176.       (kill-line (1- num-blanks))))
  177.     ))
  178.  
  179. (defun smalltalk-line-is-blank (&optional last-isnt-blank)
  180.   "Returns t if the line consists of the comment char followed
  181. by a /, or nothing in the columns past change-column"
  182.   (save-excursion
  183.     (beginning-of-line)
  184.     (cond ((looking-at "\"") (not last-isnt-blank))
  185.       ((looking-at " \|[ \t]*$") t)
  186.       (t (end-of-line)
  187.          (<= (current-column) smalltalk-change-column)))
  188.     )
  189.   )
  190.