home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / interfaces / rcs.shar / rcs.el < prev    next >
Encoding:
Text File  |  1989-06-27  |  13.1 KB  |  418 lines
  1. ;;; $Header: rcs.el,v 1.5 87/11/30 11:11:01 evs Exp $
  2. ;;; 
  3. ;;; $Log:    rcs.el,v $
  4. ;;; Revision 1.5  87/11/30  11:11:01  evs
  5. ;;;     Changed my UUCP address.
  6. ;;; 
  7. ;;; Revision 1.4  87/08/05  11:34:12  evs
  8. ;;;     RCS directory is no longer required, we now let ci figure out where
  9. ;;;     the rcs file is.  Added a log ring.
  10. ;;; 
  11. ;;; Revision 1.3  87/06/01  15:48:06  evs
  12. ;;;     Fixed bug in rcs-do-ci reported by shaddock@rti-sel.
  13. ;;; 
  14. ;;; Revision 1.2  86/12/14  21:35:37  evs
  15. ;;;     Added an rcs mode map and several new functions.
  16. ;;;     Tries to figure out new revision level by examining the
  17. ;;;     output of an  rlog -h.  Shows type of checkin in mode line.
  18. ;;; 
  19. ;;; Revision 1.1  86/12/04  12:38:19  evs
  20. ;;; Initial revision
  21. ;;; 
  22.  
  23. ;; Copyright (C) 1986, 1987 Edward V. Simpson
  24.  
  25. ;; This file is part of GNU Emacs.
  26.  
  27. ;; GNU Emacs is distributed in the hope that it will be useful,
  28. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  29. ;; accepts responsibility to anyone for the consequences of using it
  30. ;; or for whether it serves any particular purpose or works at all,
  31. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  32. ;; License for full details.
  33.  
  34. ;; Everyone is granted permission to copy, modify and redistribute
  35. ;; GNU Emacs, but only under the conditions described in the
  36. ;; GNU Emacs General Public License.   A copy of this license is
  37. ;; supposed to have been given to you along with GNU Emacs so you
  38. ;; can know your rights and responsibilities.  It should be in a
  39. ;; file named COPYING.  Among other things, the copyright notice
  40. ;; and this notice must be preserved on all copies.
  41.  
  42. ;;; Originally written by: 
  43. ;;;         Ed Simpson
  44. ;;;         P. O. Box 3140
  45. ;;;         Duke University Medical Center
  46. ;;;         Durham, NC, USA  27710
  47. ;;;        UUCP: {decvax, seismo}!mcnc!duke!evs
  48. ;;;        ARPA: evs@cs.duke.edu
  49.  
  50. ;;; User options
  51.  
  52. (defvar rcs-max-log-size 510
  53.   "*Maximum allowable size (chars) + 1 of an rcs log message.")
  54. (defvar rcs-verbose nil
  55.   "*If non-nil then rcs will ask questions before you edit the log message.")
  56.  
  57. ;;; Vars the user doesn't need to know about.
  58.  
  59. (defvar rcs-mode-map nil)
  60.  
  61. ;;; The stuff.
  62.  
  63. (defun rcs ()
  64. "Performs an RCS check-in of the file associated with the current buffer.
  65. Pops up a buffer for creation of a log message then
  66. does a \"ci -u file\", a \"ci -l file\", or a \"ci file\"."
  67.   (interactive)
  68.   (if (buffer-file-name)
  69.       (rcs-ci-co)
  70.     (error "There is no file associated with buffer %s" (buffer-name)))
  71. )
  72.  
  73. (defun rcs-ci-co ()
  74.   "Edits an rcs log message and supervises a check-in."
  75.   (let
  76.       (do-ci do-update r
  77.          (file (buffer-file-name))
  78.          (lock "u")
  79.          (force nil)
  80.          (rcs-buf (get-buffer-create "*RCS*"))
  81.          (rcs-log-buf (get-buffer-create "*RCS-Log*"))
  82.          (scratch-stuff (get-buffer-create "*Scratch-Stuff*"))
  83.          (err-msg nil))
  84.  
  85.     (save-excursion
  86.                     ; get revision level and increment
  87.       (set-buffer scratch-stuff)
  88.       (erase-buffer)
  89.       (cd (file-name-directory file))
  90.       (call-process "rlog" nil t nil "-h" (file-name-nondirectory file))
  91.       (goto-char (point-min))
  92.       (if (looking-at "rlog error:")
  93.       (setq r "1.1")
  94.     (if (not (setq r (rcs-parse-revision-level
  95.               (concat
  96.               "^locks:.*" (user-login-name) ":[ \t]*"))))
  97.         (if (string-equal "n"
  98.                   (rcs-answer-question
  99.                    (format "%s has no lock set for %s. Try anyway?"
  100.                        (user-login-name)
  101.                        (file-name-nondirectory file))
  102.                    "n" "y"))
  103.         (error "rcs aborted")
  104.           (goto-char (point-min))
  105.           (if (not (setq r (rcs-parse-revision-level "^head:[ \t]*")))
  106.           (error "can not find head revision"))))))
  107.  
  108.     (if (buffer-modified-p)
  109.     (if (equal "y"
  110.            (rcs-answer-question
  111.             (format
  112.              "%s has been modified. Should I write it out?"
  113.              (buffer-name)) "y" "n"))
  114.         (save-buffer)))
  115.  
  116.     (if rcs-verbose
  117.     (progn
  118.       (setq lock (rcs-answer-question
  119.               "Check out new version unlocked, locked, or not at all?"
  120.               "u" "l" "n"))
  121.       (if (equal "y" (rcs-answer-question
  122.               (format "Rev: %s  Change revision level?" r) "n" "y"))
  123.           (setq r (read-string "Enter new revision level: ")))))
  124.  
  125.     (save-window-excursion
  126.       (pop-to-buffer rcs-buf)
  127.       (erase-buffer)
  128.       (cd (file-name-directory file))
  129.       (set-buffer-modified-p nil)
  130.       (setq do-ci t)
  131.       (rcs-mode)
  132.       (rcs-mode-line file r lock force)
  133.       (message 
  134.        "Enter log message. Type C-c C-c when done, C-c ? for help.")
  135.       (recursive-edit)
  136.       (if do-ci
  137.       (rcs-do-ci file r lock force))
  138.       (bury-buffer rcs-buf))
  139.  
  140.     (kill-buffer scratch-stuff)
  141.  
  142.     (if do-ci
  143.     (if err-msg
  144.         (error "%s  Buffer not updated." err-msg)
  145.       (if do-update
  146.           (if (buffer-modified-p)
  147.           (error
  148.            "Warning: checked out version of file does not match buffer!")
  149.         (revert-buffer)))))
  150.   )
  151. )
  152.  
  153.  
  154. (defun rcs-do-ci (filename rev lockval forceval)
  155.   "Does the actual work of an rcs check-in.
  156. Check in the file specified by FILENAME.  REV is a string specifying the
  157. new revision level, if it is the empty string, increment the current level.
  158. LOCKVAL is a string containing the lock option letter passed to ci or is \"n\"
  159. for no check-out after the ci.  If FORCEVAL is non-nil then force the ci."
  160.   (message "Checking in file %s ..." filename)
  161.   (sit-for 0)
  162.   (goto-char (point-max))
  163.   (if (not (bolp)) (newline))
  164.   (newline)
  165.   (if  (string-equal "n" lockval)
  166.       (progn
  167.     (call-process-region (point-min) (1- (point)) "ci" nil t t
  168.                  (format "-%s%s" (if forceval "f" "r") rev)
  169.                  (file-name-nondirectory filename))
  170.     (setq do-update nil))
  171.     (call-process-region (point-min) (1- (point)) "ci" nil t t
  172.              (format "-%s%s" (if forceval "f" "r") rev)
  173.              (format "-%s" lockval)
  174.              (file-name-nondirectory filename))
  175.     (setq do-update t))
  176.   (goto-char (point-max))
  177.   (forward-line -1)
  178.   (beginning-of-line)
  179.   (if (not (looking-at "done"))        ; make sure rcs did check-in OK
  180.       (setq err-msg "Rcs error."))
  181.   (read-string "Hit return to continue ...")
  182. )
  183.  
  184.  
  185. (defun rcs-abort ()
  186.   "Abort an rcs command."
  187.   (interactive)
  188.   (if (equal "y" (rcs-answer-question "Do you really want to abort rcs?"
  189.                       "y" "n"))
  190.      (progn
  191.        (setq do-ci nil)
  192.        (exit-recursive-edit))
  193.      (error "Turkey!"))
  194. )
  195.  
  196.  
  197. (defun rcs-exit ()
  198.   "Leave the recursive edit of an rcs log message.
  199. Append the log message to the end of the rcs log ring."
  200.   (interactive)
  201.   (if (< (buffer-size) rcs-max-log-size)
  202.       (let ((min (point-min))
  203.         (max (point-max)))
  204.     (set-buffer rcs-log-buf)
  205.     (goto-char (point-max))
  206.     (insert-buffer-substring rcs-buf min max)
  207.     (insert-string "\f")
  208.     (mark-page)
  209.     (set-buffer rcs-buf)
  210.     (exit-recursive-edit))
  211.     (goto-char rcs-max-log-size)
  212.     (error
  213.      "Log must be less than %d characters. Point is now at character %d."
  214.      rcs-max-log-size rcs-max-log-size))
  215. )
  216.  
  217.  
  218. (defun rcs-insert-log ()
  219.   "Insert a log message from the rcs log ring at point."
  220.   (interactive)
  221.   (let (min max)
  222.     (save-excursion
  223.       (set-buffer rcs-log-buf)
  224.       (if (= 0 (buffer-size))
  225.       (error "Log ring is empty.")
  226.     (setq min (region-beginning))
  227.     (setq max (- (region-end) 1))))
  228.     (push-mark)
  229.     (insert-buffer-substring rcs-log-buf min max))
  230. )
  231.  
  232. (defun rcs-next-log ()
  233.   "Replace the inserted log message with the next message in the log ring.
  234. The last command must have been `rcs-insert-log,'
  235. `rcs-next-log,' or `rcs-previous-log.'"
  236.   (interactive)
  237.   (if (not (equal last-command 'rcs-insert-log))
  238.       (error "Last command was not `rcs-insert-log.'")
  239.     (delete-region (region-beginning) (region-end))
  240.     (set-buffer rcs-log-buf)
  241.     (forward-page)
  242.     (if (= (point) (point-max))
  243.     (goto-char (point-min)))
  244.     (mark-page)
  245.     (set-buffer rcs-buf)
  246.     (rcs-insert-log)
  247.     (setq this-command 'rcs-insert-log))
  248. )
  249.  
  250. (defun rcs-previous-log ()
  251.   "Replace the inserted log message with the previous message in the log ring.
  252. The last command must have been `rcs-insert-log,'
  253. `rcs-next-log,' or `rcs-previous-log.'"
  254.   (interactive)
  255.   (if (not (equal last-command 'rcs-insert-log))
  256.       (error "Last command was not `rcs-insert-log.'")
  257.     (delete-region (region-beginning) (region-end))
  258.     (set-buffer rcs-log-buf)
  259.     (if (= (point) (point-min))
  260.     (goto-char (point-max)))
  261.     (backward-page)
  262.     (mark-page)
  263.     (set-buffer rcs-buf)
  264.     (rcs-insert-log)
  265.     (setq this-command 'rcs-insert-log))
  266. )
  267.  
  268. (defun rcs-toggle-lock ()
  269.   "Toggle the rcs ci lock variable."
  270.   (interactive)
  271.   (cond
  272.    ((string-equal lock "u") (setq lock "l"))
  273.    ((string-equal lock "l") (setq lock "n"))
  274.    (t (setq lock "u")))
  275.   (rcs-mode-line file r lock force)
  276. )
  277.  
  278. (defun rcs-toggle-force ()
  279.   "Toggle the rcs ci force variable."
  280.   (interactive)
  281.   (if force (setq force nil) (setq force t))
  282.   (rcs-mode-line file r lock force)
  283. )
  284.  
  285. (defun rcs-set-revision-level ()
  286.   "Ask the user for a new revision level for an rcs ci."
  287.   (interactive)
  288.   (setq r (read-string "Enter new revision level: "))
  289.   (rcs-mode-line file r lock force)
  290. )
  291.  
  292. (defun rcs-answer-question (question defopt opt1 &optional opt2)
  293.   "Asks the user a question and prompts with legal answers.
  294. The question string is specified by QUESTION.  The string DEFOPT specifies
  295. the default answer.  OPT1 specifies the alternative answer.
  296. Optional argument OPT2 specifies a second alternative.
  297. Returns the answer given by the user.  If the user just hits the return key
  298. the default answer is returned."
  299.   (let
  300.       (val s done
  301.        (prompt (format "%s [%s,%s%s] " question defopt opt1
  302.                (if opt2 (format ",%s" opt2) ""))))
  303.     (setq done nil)
  304.     (while (not done)
  305.       (setq s (read-string prompt))
  306.       (if (equal s "")
  307.       (progn (setq val defopt) (setq done t))
  308.     (if (or (equal s defopt) (equal s opt1) (equal s opt2))
  309.         (progn (setq val s) (setq done t)))))
  310.     val)
  311. )
  312.  
  313. (defun rcs-parse-revision-level (regexp)
  314.   "Tries to parse out a revision level at the end of REGEXP.
  315. If successful increments the revision level and returns it as a string,
  316. otherwise returns nil."
  317.   (let
  318.       (beg end tmp)
  319.     (if (re-search-forward regexp (point-max) t)
  320.     (progn
  321.       (setq beg (match-end 0))
  322.       (if (re-search-forward "[0-9.]*" (point-max) t)
  323.           (progn
  324.         (setq end (match-end 0))
  325.         (goto-char beg)
  326.         (if (re-search-forward "\\([0-9]+\\.\\)+" (point-max) t)
  327.             (progn
  328.               (setq tmp (string-to-int (buffer-substring (point) end)))
  329.               (delete-region (point) end)
  330.               (insert-string (1+ tmp))
  331.               (re-search-forward "[0-9]*" (point-max) t)
  332.               (buffer-substring beg (point)))))))))
  333. )
  334.  
  335. (defun rcs-mode-line (filename rev lockval forceval)
  336.   "Set the mode line for an rcs buffer.
  337. FILENAME is the name of the file being checked in,
  338. the string REV is the new revision level, and
  339. the string LOCKVAL is the lock char for the ci.
  340. If FORCEVAL is non-nil then the modeline will indicate that the ci will
  341. be forced."
  342.   (let
  343.       ((lock-str (cond
  344.           ((string-equal lockval "u") " unlock")
  345.           ((string-equal lockval "l") " lock")
  346.           (t " no co")))
  347.        (force-str (if forceval " force" "")))
  348.     (setq mode-line-format
  349.       (concat "--%1*%1*-Emacs: %b  "
  350.           (format "[%s%s%s] %s,v" rev lock-str force-str
  351.               (file-name-nondirectory filename))
  352.           "  %M %[(%m)%]--%3p-%-"))
  353.                     ; force update of screen
  354.     (save-excursion (set-buffer (other-buffer)))
  355.     (sit-for 0))
  356. )
  357.  
  358. (defun rcs-mode ()
  359.   "Major mode for doing an rcs check-in.
  360. Calls the value of text-mode-hook then rcs-mode-hook.
  361. Like Text Mode but with these additional comands:
  362. C-c C-c        proceed with check-in
  363. C-x C-s        same as C-c C-c
  364. C-c i        insert log message from the \"log ring\"
  365. C-c n        replace inserted log message with next one in \"log ring\"
  366. C-c p        replace inserted log message with previous one in \"log ring\"
  367. C-c l        toggle the \"lock variable\"
  368. C-c r        set a new revision level
  369. C-c f        toggle the \"force variable\"
  370. C-c a        abort this check-in
  371. C-c ?        show this message
  372.  
  373. Every time a check-in is attempted the current log message is appended to
  374. the \"log ring.\"
  375.  
  376. The \"lock variable\" determines what type of check-out to do after a
  377. successful check-in.  Possible values are:
  378.     lock        check out new version locked
  379.     unlock        check out new version unlocked
  380.     no co        do not check out new version
  381.  
  382. If the \"force variable\" is set then the check-in will be forced even if
  383. this version is not different from the previous version.
  384.  
  385. Global user options:
  386.     rcs-max-log-size    specifies the maximum allowable size
  387.                 of a log message plus one.
  388.     rcs-verbose        if non-nil then ask questions before
  389.                 editing log message."
  390.   (interactive)
  391.   (set-syntax-table text-mode-syntax-table)
  392.   (use-local-map rcs-mode-map)
  393.   (setq local-abbrev-table text-mode-abbrev-table)
  394.   (setq major-mode 'rcs-mode)
  395.   (setq mode-name "RCS")
  396.   (run-hooks 'text-mode-hook 'rcs-mode-hook)
  397. )
  398.  
  399. (if rcs-mode-map
  400.     nil
  401.   (setq rcs-mode-map (make-sparse-keymap))
  402.   (define-key rcs-mode-map "\C-c?" 'describe-mode)
  403.   (define-key rcs-mode-map "\C-ci" 'rcs-insert-log)
  404.   (define-key rcs-mode-map "\C-cn" 'rcs-next-log)
  405.   (define-key rcs-mode-map "\C-cp" 'rcs-previous-log)
  406.   (define-key rcs-mode-map "\C-cl" 'rcs-toggle-lock)
  407.   (define-key rcs-mode-map "\C-cr" 'rcs-set-revision-level)
  408.   (define-key rcs-mode-map "\C-cf" 'rcs-toggle-force)
  409.   (define-key rcs-mode-map "\C-ca" 'rcs-abort)
  410.   (define-key rcs-mode-map "\C-c\C-c" 'rcs-exit)
  411.   (define-key rcs-mode-map "\C-x\C-s" 'rcs-exit)
  412.   (save-excursion            ; initialize log ring
  413.     (set-buffer (get-buffer-create "*RCS-Log*"))
  414.     (erase-buffer)
  415.     (make-local-variable 'page-delimiter)
  416.     (setq page-delimiter "\f"))
  417. )
  418.