home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / packages / sccs.el < prev    next >
Encoding:
Text File  |  1993-03-24  |  28.4 KB  |  886 lines
  1. ;; sccs.el -- easy-to-use SCCS control from within Emacs
  2. ;;    @(#)sccs.el    3.5
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20. ;;;
  21. ;;; You can blame this one on Eric S. Raymond (eric@snark.thyrsus.com).
  22. ;;; It is distantly derived from an rcs mode written by Ed Simpson
  23. ;;; ({decvax, seismo}!mcnc!duke!dukecdu!evs) in years gone by
  24. ;;; and revised at MIT's Project Athena.
  25. ;;; 
  26. ;;; Made to work for Lucid Emacs by persons who don't know SCCS.
  27.  
  28. ;; User options
  29.  
  30. (defvar sccs-bin-directory
  31.   (cond ((file-executable-p "/usr/sccs/unget") "/usr/sccs")
  32.     ((file-executable-p "/usr/bin/unget") "/usr/bin")
  33.     ((file-directory-p "/usr/sccs") "/usr/sccs")
  34.     ((file-directory-p "/usr/bin/sccs") "/usr/bin/sccs")
  35.     (t "/usr/bin")))
  36.  
  37. (defvar sccs-max-log-size 510
  38.   "*Maximum allowable size of an SCCS log message.")
  39. (defvar sccs-diff-command '("diff" "-c")
  40.   "*The command/flags list to be used in constructing SCCS diff commands.")
  41. (defvar sccs-headers-wanted '("\%\W\%")
  42.   "*SCCS header keywords to be inserted when sccs-insert-header is executed.")
  43. (defvar sccs-insert-static t
  44.   "*Insert a static character string when inserting SCCS headers in C mode.")
  45. (defvar sccs-mode-expert nil
  46.   "*Treat user as expert; suppress yes-no prompts on some things.")
  47.  
  48. ;; Vars the user doesn't need to know about.
  49.  
  50. (defvar sccs-log-entry-mode nil)
  51. (defvar sccs-current-major-version nil)
  52.  
  53. ;; Some helper functions
  54.  
  55. (defun sccs-name (file &optional letter)
  56.   "Return the sccs-file name corresponding to a given file."
  57.   (format "%sSCCS/%s.%s"
  58.       (concat (file-name-directory (expand-file-name file)))
  59.       (or letter "s")
  60.       (concat (file-name-nondirectory (expand-file-name file)))))
  61.  
  62. (defun sccs-lock-info (file index)
  63.    "Return the nth token in a file's SCCS-lock information."
  64.    (let
  65.        ((pfile (sccs-name file "p")))
  66.      (and (file-exists-p pfile)
  67.       (save-excursion
  68.         (find-file pfile)
  69.         (auto-save-mode nil)
  70.         (replace-string " " "\n")
  71.         (goto-char (point-min))
  72.         (forward-line index)
  73.         (prog1
  74.         (buffer-substring (point) (progn (end-of-line) (point)))
  75.           (set-buffer-modified-p nil)
  76.           (kill-buffer (current-buffer)))
  77.         )
  78.       )
  79.      )
  80.    )
  81.  
  82. (defun sccs-locking-user (file)
  83.   "Return the name of the person currently holding a lock on FILE.
  84. Return nil if there is no such person."
  85.   (sccs-lock-info file 2)
  86.   )
  87.  
  88. (defun sccs-locked-revision (file)
  89.   "Return the revision number currently locked for FILE, nil if none such."
  90.   (sccs-lock-info file 1)
  91.   )
  92.  
  93. (defmacro error-occurred (&rest body)
  94.   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  95.  
  96. ;; There has *got* to be a better way to do this...
  97. (defmacro chmod (perms file)
  98.   (list 'call-process "chmod" nil nil nil perms file))
  99.  
  100. (defun sccs-save-vars (sid)
  101.   (save-excursion
  102.     (find-file "SCCS/emacs-vars.el")
  103.     (erase-buffer)
  104.     (insert "(setq sccs-current-major-version \"" sid "\")")
  105.     (basic-save-buffer)
  106.     )
  107.   )
  108.  
  109. (defun sccs-load-vars ()
  110.   (if (error-occurred (load-file "SCCS/emacs-vars.el"))
  111.       (setq sccs-current-major-version "1"))
  112. )
  113.  
  114. ;; The following functions do most of the real work
  115.  
  116. (defun sccs-get-version (file sid)
  117.    "For the given FILE, retrieve a copy of the version with given SID.
  118. The text is retrieved into a tempfile.  Return the tempfile name, or nil
  119. if no such version exists."
  120.   (let (oldversion vbuf)
  121.     (setq oldversion (sccs-name file (or sid "new")))
  122.     (setq vbuf (create-file-buffer oldversion))
  123.     (prog1
  124.     (if (not (error-occurred
  125.          (sccs-do-command vbuf "get" file
  126.                   (and sid (concat "-r" sid))
  127.                   "-p" "-s")))
  128.         (save-excursion
  129.           (set-buffer vbuf)
  130.           (write-region (point-min) (point-max) oldversion t 0)
  131.           oldversion)
  132.       )
  133.       (kill-buffer vbuf)
  134.       )
  135.     )
  136.   )
  137.  
  138. (defun sccs-mode-line (file)
  139.   "Set the mode line for an SCCS buffer.
  140. FILE is the file being visited to put in the modeline."
  141.   (setq mode-line-process
  142.     (if (file-exists-p (sccs-name file "p"))
  143.         (format " <SCCS: %s>" (sccs-locked-revision file))
  144.       ""))
  145.  
  146.     ; force update of screen
  147.     (save-excursion (set-buffer (other-buffer)))
  148.     (sit-for 0)
  149.     )
  150.  
  151. (defun sccs-do-command (buffer command file &rest flags)
  152.   "  Execute an SCCS command, notifying the user and checking for errors."
  153.   (setq file (expand-file-name file))
  154.   (message (format "Running %s on %s..." command file))
  155.   (let ((status
  156.      (save-window-excursion
  157.        (set-buffer (get-buffer-create buffer))
  158.        (erase-buffer)
  159.        (while (and flags (not (car flags)))
  160.          (setq flags (cdr flags)))
  161.        (setq flags (append flags (and file (list (sccs-name file)))))
  162.        (let ((default-directory (file-name-directory (or file "./")))
  163.          (exec-path (cons sccs-bin-directory exec-path)))
  164.          (apply 'call-process command nil t nil flags)
  165.          )
  166.        (goto-char (point-max))
  167.        (previous-line 1)
  168.        (if (looking-at "ERROR")
  169.            (progn
  170.          (previous-line 1)
  171.          (print (cons command flags))
  172.          (next-line 1)
  173.          nil)
  174.          t))))
  175.     (if status
  176.     (message (format "Running %s...OK" command))
  177.       (pop-to-buffer buffer)
  178.       (error (format "Running %s...FAILED" command))))
  179.   (if file (sccs-mode-line file)))
  180.  
  181. (defun sccs-shell-command (command)
  182.   "Like shell-command except that the *Shell Command Output*buffer
  183. is created even if the command does not output anything"
  184.   (shell-command command)
  185.   (get-buffer-create "*Shell Command Output*"))
  186.  
  187. (defun sccs-tree-walk (func &rest optargs)
  188.   "Apply FUNC to each SCCS file under the default directory.
  189. If present, OPTARGS are also passed."
  190.   (sccs-shell-command (concat
  191.                "find " default-directory " -print | grep 'SCCS/s\\.'"))
  192.   (set-buffer "*Shell Command Output*")
  193.   (goto-char (point-min))
  194.   (replace-string "SCCS/s." "")
  195.   (goto-char (point-min))
  196.   (if (eobp)
  197.       (error "No SCCS files under %s" default-directory))
  198.   (while (not (eobp))
  199.     (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
  200.       (apply func file optargs)
  201.       )
  202.     (forward-line 1)
  203.     )
  204.   )
  205.  
  206. (defun sccs-init ()
  207.   (define-key (current-global-map) "\C-c?" 'describe-mode)
  208.   (define-key (current-global-map) "\C-cn" 'sccs)
  209.   (define-key (current-global-map) "\C-cm" 'sccs-register-file)
  210.   (define-key (current-global-map) "\C-ch" 'sccs-insert-headers)
  211.   (define-key (current-global-map) "\C-cd" 'sccs-revert-diff)
  212.   (define-key (current-global-map) "\C-cp" 'sccs-prs)
  213.   (define-key (current-global-map) "\C-cr" 'sccs-revert-buffer)
  214.   (define-key (current-global-map) "\C-c\C-d" 'sccs-version-diff)
  215.   (define-key (current-global-map) "\C-c\C-p" 'sccs-pending)
  216.   (define-key (current-global-map) "\C-c\C-r" 'sccs-registered)
  217.   )
  218.  
  219. ;; Here's the major entry point
  220.  
  221. (defun sccs (verbose)
  222.   "*Do the next logical SCCS operation on the file in the current buffer.
  223. You must have an SCCS subdirectory in the same directory as the file being
  224. operated on.
  225.    If the file is not already registered with SCCS, this does an admin -i
  226. followed by a get -e.
  227.    If the file is registered and not locked by anyone, this does a get -e.
  228.    If the file is registered and locked by the calling user, this pops up a
  229. buffer for creation of a log message, then does a delta -n on the file.
  230. A read-only copy of the changed file is left in place afterwards.
  231.    If the file is registered and locked by someone else, an error message is
  232. returned indicating who has locked it."
  233.   (interactive "P")
  234.   (sccs-init)
  235.   (if (buffer-file-name)
  236.       (let
  237.       (do-update revision owner
  238.              (file (buffer-file-name))
  239.              (sccs-file (sccs-name (buffer-file-name)))
  240.              (sccs-log-buf (get-buffer-create "*SCCS-Log*"))
  241.              (err-msg nil))
  242.  
  243.     ;; if there is no SCCS file corresponding, create one
  244.     (if (not (file-exists-p sccs-file))
  245.         (progn
  246.           (sccs-load-vars)
  247.           (sccs-admin 
  248.            file
  249.            (cond 
  250.         (verbose (read-string "Initial SID: "))
  251.         ((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
  252.         (t sccs-current-major-version))
  253.            )
  254.           )
  255.       )
  256.  
  257.     (cond
  258.  
  259.      ;; if there is no lock on the file, assert one and get it
  260.      ((not (file-exists-p (sccs-name file "p")))
  261.       (progn
  262.         (sccs-get file t)
  263.         (revert-buffer nil t)
  264.         (sccs-mode-line file)
  265.         ))
  266.  
  267.      ;; a checked-out version exists, but the user may not own the lock
  268.      ((not (string-equal
  269.         (setq owner (sccs-locking-user file)) (user-login-name)))
  270.       (error "Sorry, %s has that file checked out" owner))
  271.  
  272.      ;; OK, user owns the lock on the file 
  273.      (t (progn
  274.  
  275.           ;; if so, give luser a chance to save before delta-ing.
  276.           (if (and (buffer-modified-p)
  277.                (or
  278.             sccs-mode-expert
  279.             (y-or-n-p (format "%s has been modified. Write it out? "
  280.                       (buffer-name)))))
  281.                (save-buffer))
  282.  
  283.           (setq revision (sccs-locked-revision file))
  284.  
  285.           ;; user may want to set nonstandard parameters
  286.           (if verbose
  287.           (if (or sccs-mode-expert (y-or-n-p 
  288.                (format "SID: %s  Change revision level? " revision)))
  289.               (setq revision (read-string "New revision level: "))))
  290.  
  291.           ;; OK, let's do the delta
  292.           (if
  293.           ;; this excursion returns t if the new version was saved OK
  294.           (save-window-excursion
  295.             (pop-to-buffer (get-buffer-create "*SCCS*"))
  296.             (erase-buffer)
  297.             (set-buffer-modified-p nil)
  298.             (sccs-mode)
  299.             (message 
  300.              "Enter log message. Type C-c C-c when done, C-c ? for help.")
  301.             (prog1
  302.             (and (not (error-occurred (recursive-edit)))
  303.                  (not (error-occurred (sccs-delta file revision))))
  304.               (setq buffer-file-name nil)
  305.               (bury-buffer "*SCCS*")))
  306.  
  307.           ;; if the save went OK do some post-checking
  308.           (if (buffer-modified-p)
  309.               (error
  310.                "Delta-ed version of file does not match buffer!")
  311.             (progn
  312.               ;; sccs-delta already turned off write-privileges on the
  313.               ;; file, let's not re-fetch it unless there's something
  314.               ;; in it that get would expand
  315.               (if (sccs-check-headers)
  316.               (sccs-get file nil))
  317.               (revert-buffer nil t)
  318.               (sccs-mode-line file)
  319.               (run-hooks 'sccs-delta-ok)
  320.               )
  321.             ))))))
  322.     (error "There is no file associated with buffer %s" (buffer-name))))
  323.  
  324. (defun sccs-insert-last-log ()
  325.   "*Insert the log message of the last SCCS check in at point."
  326.   (interactive)
  327.   (insert-buffer sccs-log-buf))
  328.  
  329. ;;; These functions help the sccs entry point
  330.  
  331. (defun sccs-get (file writeable)
  332.   "Retrieve a copy of the latest delta of the given file."
  333.     (sccs-do-command "*SCCS*" "get" file (if writeable "-e")))
  334.  
  335. (defun sccs-admin (file sid)
  336.   "Checks a file into sccs.
  337. FILE is the unmodified name of the file.  SID should be the base-level sid to
  338. check it in under."
  339.   ; give a change to save the file if it's modified
  340.   (if (and (buffer-modified-p)
  341.        (y-or-n-p (format "%s has been modified. Write it out? "
  342.                  (buffer-name))))
  343.       (save-buffer))
  344.   (sccs-do-command "*SCCS*" "admin" file
  345.            (concat "-i" file) (concat "-r" sid))
  346.   (chmod "-w" file)
  347.   (if (sccs-check-headers)
  348.       (sccs-get file nil))    ;; expand SCCS headers
  349.   (revert-buffer nil t)
  350.   (sccs-mode-line file)
  351. )
  352.  
  353. (defun sccs-delta (file &optional rev comment)
  354.    "Delta the file specified by FILE.
  355. The optional argument REV may be a string specifying the new revision level
  356. \(if nil increment the current level). The file is retained with write
  357. permissions zeroed. COMMENT is a comment string; if omitted, the contents of
  358. the current buffer up to point becomes the comment for this delta."
  359.   (if (not comment)
  360.       (progn
  361.     (goto-char (point-max))
  362.     (if (not (bolp)) (newline))
  363.     (newline)
  364.     (setq comment (buffer-substring (point-min) (1- (point)))))
  365.     )
  366.   (sccs-do-command "*SCCS*" "delta" file "-n"
  367.        (if rev (format "-r%s" rev))
  368.        (format "-y%s" comment))
  369.   (chmod "-w" file))
  370.  
  371. (defun sccs-delta-abort ()
  372.   "Abort an SCCS delta command."
  373.   (interactive)
  374.   (if (or sccs-mode-expert (y-or-n-p "Abort the delta? "))
  375.       (progn
  376.     (delete-window)
  377.     (error "Delta aborted")))
  378.   )
  379.  
  380. (defun sccs-log-exit ()
  381.   "Leave the recursive edit of an SCCS log message."
  382.   (interactive)
  383.   (if (< (buffer-size) sccs-max-log-size)
  384.      (progn
  385.        (copy-to-buffer sccs-log-buf (point-min) (point-max))
  386.        (exit-recursive-edit)
  387.        (delete-window))
  388.      (progn
  389.        (goto-char sccs-max-log-size)
  390.        (error
  391.         "Log must be less than %d characters. Point is now at char %d."
  392.         sccs-max-log-size sccs-max-log-size)))
  393. )
  394.  
  395. ;; Additional entry points for examining version histories
  396.  
  397. (defun sccs-revert-diff (&rest flags)
  398.   "*Compare the version being edited with the last checked-in revision.
  399. Or, if given a prefix argument, with another specified revision."
  400.   (interactive)
  401.   (let (old file)
  402.     (if
  403.     (setq old (sccs-get-version (buffer-file-name) 
  404.                     (and
  405.                      current-prefix-arg
  406.                      (read-string "Revision to compare against: "))
  407.                     ))
  408.     (progn
  409.       (if (and (buffer-modified-p)
  410.            (or
  411.             sccs-mode-expert
  412.             (y-or-n-p (format "%s has been modified. Write it out? "
  413.                       (buffer-name)))))
  414.           (save-buffer))
  415.  
  416.       (setq file (buffer-file-name))
  417.       (set-buffer (get-buffer-create "*SCCS*"))
  418.       (erase-buffer)
  419.       (apply 'call-process (car sccs-diff-command) nil t nil
  420.          (append (cdr sccs-diff-command) flags (list old) (list file)))
  421.       (set-buffer-modified-p nil)
  422.       (goto-char (point-min))
  423.       (delete-file old)
  424.       (if (equal (point-min) (point-max))
  425.           (message (format "No changes to %s since last get." file))
  426.           (pop-to-buffer "*SCCS*")
  427.           )
  428.       )
  429.       )
  430.     )
  431.   )
  432.  
  433. (defun sccs-prs ()
  434.   "*List the SCCS log of the current buffer in an emacs window."
  435.   (interactive)
  436.   (if (and buffer-file-name (file-exists-p (sccs-name buffer-file-name "s")))
  437.       (progn
  438.     (sccs-do-command "*SCCS*" "prs" buffer-file-name)
  439.     (pop-to-buffer (get-buffer-create "*SCCS*"))
  440.     )
  441.     (error "There is no SCCS file associated with this buffer")
  442.     )
  443.   )
  444.  
  445. (defun sccs-version-diff (file rel1 rel2)
  446.   "*For FILE, report diffs between two stored deltas REL1 and REL2 of it."
  447.   (interactive "fFile: \nsOlder version: \nsNewer version: ")
  448.   (if (string-equal rel1 "") (setq rel1 nil))
  449.   (if (string-equal rel2 "") (setq rel2 nil))
  450.   (set-buffer (get-buffer-create "*SCCS*"))
  451.   (erase-buffer)
  452.   (sccs-vdiff file rel1 rel2)
  453.   (set-buffer-modified-p nil)
  454.   (goto-char (point-min))
  455.   (if (equal (point-min) (point-max))
  456.       (message (format "No changes to %s between %s and %s." file rel1 rel2))
  457.     (pop-to-buffer "*SCCS*")
  458.     )
  459.   )
  460.  
  461. (defun sccs-vdiff (file rel1 rel2 &optional flags)
  462.   "Compare two deltas into the current buffer."
  463.   (let (vers1 vers2)
  464.     (and
  465.      (setq vers1 (sccs-get-version file rel1))
  466.      (setq vers2 (if rel2 (sccs-get-version file rel2) file))
  467. ;     (prog1
  468. ;     (save-excursion
  469. ;       (not (error-occurred
  470. ;         (call-process "prs" nil t t
  471. ;                   (sccs-name file))))
  472. ;     )
  473. ;       )
  474.      (unwind-protect
  475.      (apply 'call-process (car sccs-diff-command) nil t t
  476.         (append (cdr sccs-diff-command) flags (list vers1) (list vers2)))
  477.        (condition-case () (delete-file vers1) (error nil))
  478.        (if rel2
  479.        (condition-case () (delete-file vers2) (error nil)))
  480.        )
  481.      )
  482.     )
  483.   )
  484.  
  485. ;; SCCS header insertion code
  486.  
  487. (defun sccs-insert-headers ()
  488.   "*Insert headers for use with the Source Code Control System.
  489. Headers desired are inserted at the start of the buffer, and are pulled from 
  490. the variable sccs-headers-wanted"
  491.   (interactive)
  492.   (save-excursion
  493.     (save-restriction
  494.       (widen)
  495.       (if (or (not (sccs-check-headers))
  496.           (y-or-n-p "SCCS headers already exist.  Insert another set?"))
  497.       (progn
  498.          (goto-char (point-min))
  499.          (run-hooks 'sccs-insert-headers-hook)
  500.          (cond ((eq major-mode 'c-mode) (sccs-insert-c-header))
  501.            ((eq major-mode 'lisp-mode) (sccs-insert-lisp-header))
  502.            ((eq major-mode 'emacs-lisp-mode) (sccs-insert-lisp-header))
  503.            ((eq major-mode 'scheme-mode) (sccs-insert-lisp-header))
  504.            ((eq major-mode 'nroff-mode) (sccs-insert-nroff-header))
  505.            ((eq major-mode 'plain-tex-mode) (sccs-insert-tex-header))
  506.            ((eq major-mode 'texinfo-mode) (sccs-insert-texinfo-header))
  507.            (t (sccs-insert-generic-header))))))))
  508.  
  509. (defun sccs-insert-c-header ()
  510.   (let (st en)
  511.     (insert "/*\n")
  512.     (mapcar '(lambda (s)
  513.            (insert " *\t" s "\n"))
  514.         sccs-headers-wanted)
  515.     (insert " */\n\n")
  516.     (if (and sccs-insert-static 
  517.          (not (string-match "\\.h$" (buffer-file-name))))
  518.     (progn
  519.       (insert "#ifndef lint\n"
  520.           "static char *sccsid")
  521. ;;      (setq st (point))
  522. ;;      (insert (file-name-nondirectory (buffer-file-name)))
  523. ;;      (setq en (point))
  524. ;;      (subst-char-in-region st en ?. ?_)
  525.       (insert " = \"\%\W\%\";\n"
  526.           "#endif /* lint */\n\n")))
  527.     (run-hooks 'sccs-insert-c-header-hook)))
  528.  
  529. (defun sccs-insert-lisp-header ()
  530.   (mapcar '(lambda (s) 
  531.           (insert ";;;\t" s "\n"))
  532.       sccs-headers-wanted)
  533.   (insert "\n")
  534.   (run-hooks 'sccs-insert-lisp-header-hook))
  535.  
  536. (defun sccs-insert-nroff-header ()
  537.   (mapcar '(lambda (s) 
  538.           (insert ".\\\"\t" s "\n"))
  539.       sccs-headers-wanted)
  540.   (insert "\n")
  541.   (run-hooks 'sccs-insert-nroff-header-hook))
  542.  
  543. (defun sccs-insert-tex-header ()
  544.   (mapcar '(lambda (s) 
  545.           (insert "%%\t" s "\n"))
  546.       sccs-headers-wanted)
  547.   (insert "\n")
  548.   (run-hooks 'sccs-insert-tex-header-hook))
  549.  
  550. (defun sccs-insert-texinfo-header ()
  551.   (mapcar '(lambda (s) 
  552.           (insert "@comment\t" s "\n"))
  553.       sccs-headers-wanted)
  554.   (insert "\n")
  555.   (run-hooks 'sccs-insert-texinfo-header-hook))
  556.  
  557. (defun sccs-insert-generic-header ()
  558.   (let* ((comment-start-sccs (or comment-start "#"))
  559.      (comment-end-sccs (or comment-end ""))
  560.      (dont-insert-nl-p (string-match "\n" comment-end-sccs)))
  561.     (mapcar '(lambda (s)
  562.            (insert comment-start-sccs "\t" s ""
  563.                comment-end-sccs (if dont-insert-nl-p "" "\n")))
  564.       sccs-headers-wanted)
  565.   (insert comment-start-sccs comment-end-sccs (if dont-insert-nl-p "" "\n"))))
  566.  
  567. (defun sccs-check-headers ()
  568.   "Check if the current file has any SCCS headers in it."
  569.   (interactive)
  570.   (save-excursion
  571.     (goto-char (point-min))
  572.     (re-search-forward  "%[MIRLBSDHTEGUYFPQCZWA]%" (point-max) t)))
  573.  
  574. ;; Status-checking functions
  575.  
  576. (defun sccs-status (prefix legend)
  577.    "List all files underneath the current directory matching a prefix type."
  578.    (sccs-shell-command
  579.     (format "find . -print | grep 'SCCS/%s\\.'" prefix))
  580.    (if
  581.        (save-excursion
  582.      (set-buffer "*Shell Command Output*")
  583.      (if (= (point-max) (point-min))
  584.          (not (message
  585.            "No files are currently %s under %s"
  586.            legend default-directory))
  587.        (progn
  588.          (goto-char (point-min))
  589.          (insert
  590.           "The following files are currently " legend
  591.           " under " default-directory ":\n")
  592.          (replace-string (format "SCCS/%s." prefix) "")
  593.          )
  594.        )
  595.      )
  596.        (pop-to-buffer "*Shell Command Output*")
  597.        )
  598.      )
  599.  
  600. (defun sccs-pending ()
  601.   "*List all files currently SCCS locked."
  602.   (interactive)
  603.   (sccs-status "p" "locked"))
  604.  
  605. (defun sccs-registered ()
  606.   "*List all files currently SCCS registered."
  607.   (interactive)
  608.   (sccs-status "s" "registered"))
  609.        
  610. (defun sccs-register-file (override)
  611.   "*Register the file visited by the current buffer into SCCS."
  612.   (interactive "P")
  613.   (if (file-exists-p (sccs-name (buffer-file-name)))
  614.       (error "This file is already registered into SCCS.")
  615.     (progn
  616.       (if (and (buffer-modified-p)
  617.            (or
  618.         sccs-mode-expert
  619.         (y-or-n-p (format "%s has been modified. Write it out? "
  620.                   (buffer-name)))))
  621.       (save-buffer))
  622.       (sccs-load-vars)
  623.       (sccs-admin 
  624.        (buffer-file-name)
  625.        (cond 
  626.     (override (read-string "Initial SID: "))
  627.     ((error-occurred (load-file "SCCS/emacs-vars.el")) "1")
  628.     (t sccs-current-major-version))
  629.        )
  630.       )
  631.     )
  632.   )
  633.  
  634. ;; Major functions for release-tracking and generation.
  635.  
  636. (defun sccs-release-diff (rel1 rel2)
  637.   "*Diff all files below default-directory between versions REL1 and REL2.
  638. The report goes to a shell output buffer which is popped to.  If REL2 is
  639. omitted or nil, the comparison is done against the most recent version."
  640.   (interactive "sOlder version: \nsNewer version: ")
  641.   (if (string-equal rel1 "") (setq rel1 nil))
  642.   (if (string-equal rel2 "") (setq rel2 nil))
  643.   (sccs-shell-command (concat
  644.                "find " default-directory " -print | grep 'SCCS/s\\.'"))
  645.   (set-buffer "*Shell Command Output*")
  646.   (goto-char (point-min))
  647.   (replace-string "SCCS/s." "")
  648.   (goto-char (point-min))
  649.   (if (eobp)
  650.       (error "No SCCS files under %s" default-directory))
  651.   (let
  652.       ((sccsbuf (get-buffer-create "*SCCS*")))
  653.     (save-excursion
  654.       (set-buffer sccsbuf)
  655.       (erase-buffer)
  656.       (insert (format "Diffs from %s to %s.\n\n"
  657.               (or rel1 "current") (or rel2 "current"))))
  658.     (while (not (eobp))
  659.      (let ((file (buffer-substring (point) (progn (end-of-line) (point)))))
  660.        (save-excursion
  661.          (set-buffer sccsbuf)
  662.          (set-buffer-modified-p nil)
  663.          (sccs-vdiff file rel1 rel2)
  664.          (if (buffer-modified-p)
  665.          (insert "\n"))
  666.          )
  667.        (forward-line 1)
  668.        )
  669.      )
  670.     (kill-buffer "*Shell Command Output*")
  671.     (pop-to-buffer sccsbuf)
  672.     (insert "\nEnd of diffs.\n")
  673.     (goto-char (point-min))
  674.     (replace-string (format "/SCCS/%s." rel1) "/")
  675.     (goto-char (point-min))
  676.     (replace-string (format "/SCCS/%s." rel2) "/new/")
  677.     (goto-char (point-min))
  678.     (replace-string "/SCCS/new." "/new/")
  679.     (goto-char (point-min))
  680.     (replace-regexp (concat "^*** " default-directory) "*** ")
  681.     (goto-char (point-min))
  682.     (replace-regexp (concat "^--- " default-directory) "--- ")
  683.     (goto-char (point-min))
  684.     (set-buffer-modified-p nil)
  685.     )
  686.   )
  687.  
  688. (defun sccs-dummy-delta (file sid)
  689.   "Make a dummy delta to the given FILE with the given SID."
  690.   (interactive "sFile: \nsRelease ID: ")
  691.   (if (not (sccs-locked-revision file))
  692.       (sccs-get file t))
  693.   ;; Grottiness alert -- to get around SCCS's obsessive second-guessing we
  694.   ;; have to mung the p-file
  695.   (save-excursion
  696.     (let ((pfile (sccs-name file "p")))
  697.       (chmod "u+w" pfile)
  698.       (find-file pfile)
  699.       (auto-save-mode nil)
  700.       (replace-regexp "^\\([0-9.]+\\) \\([0-9.]+\\)" (concat "\\1 " sid) t)
  701.       (write-region (point-min) (point-max) pfile t 0)
  702.       (chmod "u-w" pfile)
  703.       (set-buffer-modified-p nil)
  704.       (kill-buffer (current-buffer))
  705.       )
  706.     )
  707.   (sccs-delta file sid (concat "Release " sid))
  708.   (sccs-get file nil)
  709.   (sccs-save-vars sid)
  710.   )
  711.  
  712. (defun sccs-delta-release (sid)
  713.   "*Delta everything underneath the current directory to mark it as a release."
  714.   (interactive "sRelease: ")
  715.   (sccs-tree-walk 'sccs-dummy-delta sid)
  716.   (kill-buffer "*SCCS*")
  717.   )
  718.  
  719. ;; Miscellaneous other entry points
  720.  
  721. (defun sccs-revert-buffer ()
  722.   "*Revert the current buffer's file back to the last saved version."
  723.   (interactive)
  724.   (let ((file (buffer-file-name)))
  725.     (if (y-or-n-p (format "Revert file %s to last SCCS revision?" file))
  726.     (progn
  727.       (delete-file file)
  728.       (delete-file (sccs-name file "p"))
  729.       (rename-file (sccs-get-version file nil) file)
  730.       (chmod "-w" file)
  731.       (revert-buffer nil t)
  732.       (sccs-mode-line file)))))
  733.  
  734. (defun sccs-rename-file (old new)
  735.   "*Rename a file, taking its SCCS files with it."
  736.   (interactive "fOld name: \nFNew name: ")
  737.   (let ((owner (sccs-locking-user old)))
  738.     (if (and owner (not (string-equal owner (user-login-name))))
  739.     (error "Sorry, %s has that file checked out" owner))
  740.     )
  741.   (rename-file old new)
  742.   (if (file-exists-p (sccs-name old "p"))
  743.       (rename-file (sccs-name old "p") (sccs-name new "p")))
  744.   (if (file-exists-p (sccs-name old "s"))
  745.       (rename-file (sccs-name old "s") (sccs-name new "s")))
  746.   )
  747.  
  748. ;; Set up key bindings for SCCS use, e.g. while editing log messages
  749.  
  750. (defun sccs-mode ()
  751.   "Minor mode for driving the SCCS tools.
  752.  
  753. These bindings are added to the global keymap when you enter this mode:
  754. \\[sccs]    perform next logical SCCS operation (`sccs') on current file
  755. \\[sccs-register-file]        register current file into SCCS
  756. \\[sccs-insert-headers]        insert SCCS headers in current file
  757. \\[sccs-prs]        display change history of current file
  758. \\[sccs-revert-buffer]        revert buffer to last saved version
  759. \\[sccs-revert-diff]        show difference between buffer and last saved delta
  760. \\[sccs-pending]        show all files currently locked by any user in or below .
  761. \\[sccs-registered]        show all files registered into SCCS in or below .
  762. \\[sccs-version-diff]        show diffs between saved versions for all files in or below .
  763.  
  764. When you generate headers into a buffer using C-c h, the value of
  765. sccs-insert-headers-hook is called before insertion. If the file is
  766. recognized a C or Lisp source, sccs-insert-c-header-hook or
  767. sccs-insert-lisp-header-hook is called after insertion respectively.
  768.  
  769. While you are entering a change log message for a delta, the following
  770. additional bindings will be in effect.
  771.  
  772. \\[sccs-log-exit]        proceed with check in, ending log message entry
  773. \\[sccs-insert-last-log]        insert log message from last check-in
  774. \\[sccs-delta-abort]        abort this delta check-in
  775.  
  776. Entry to the change-log submode calls the value of text-mode-hook, then
  777. the value sccs-mode-hook.
  778.  
  779. Global user options:
  780.         sccs-mode-expert        suppresses some conformation prompts,
  781.                 notably for delta aborts and file saves.
  782.     sccs-max-log-size    specifies the maximum allowable size
  783.                 of a log message plus one.
  784.     sccs-diff-command    A list consisting of the command and flags
  785.                 to be used for generating context diffs.
  786.     sccs-headers-wanted    which %-keywords to insert when adding
  787.                 SCCS headers with C-c h
  788.     sccs-insert-static    if non-nil, SCCS keywords inserted in C files
  789.                 get stuffed in a static string area so that
  790.                 what(1) can see them in the compiled object
  791.                 code.
  792. "
  793.   (interactive)
  794.   (set-syntax-table text-mode-syntax-table)
  795.   (use-local-map sccs-log-entry-mode)
  796.   (setq local-abbrev-table text-mode-abbrev-table)
  797.   (setq major-mode 'sccs-mode)
  798.   (setq mode-name "SCCS Change Log Entry")
  799.   (run-hooks 'text-mode-hook 'sccs-mode-hook)
  800. )
  801.  
  802. ;; Initialization code, to be done just once at load-time
  803. (if sccs-log-entry-mode
  804.     nil
  805.   (setq sccs-log-entry-mode (make-sparse-keymap))
  806.   (define-key sccs-log-entry-mode "\C-ci" 'sccs-insert-last-log)
  807.   (define-key sccs-log-entry-mode "\C-c\C-i" 'sccs-insert-last-log)
  808.   (define-key sccs-log-entry-mode "\C-ca" 'sccs-delta-abort)
  809.   (define-key sccs-log-entry-mode "\C-c\C-a" 'sccs-delta-abort)
  810.   (define-key sccs-log-entry-mode "\C-c\C-c" 'sccs-log-exit)
  811.   (define-key sccs-log-entry-mode "\C-x\C-s" 'sccs-log-exit)
  812.   )
  813.  
  814.  
  815. ;;; Lucid Emacs supprot
  816.  
  817. (defconst sccs-menu
  818.   '("SCCS Commands"
  819.  
  820.     ["SCCS"            sccs            t    nil] ; C-c n
  821.     ["Insert Headers"        sccs-insert-headers    t]         ; C-c h
  822.     "----"
  823.     ["Delta file"        sccs-dummy-delta    t    nil]
  824.     ["Register file"        sccs-register-file    t    nil] ; C-c h
  825.     ["Revert File"        sccs-revert-buffer    t    nil] ; C-c r
  826.     ["Rename File"        sccs-rename-file    t    nil]
  827.     "----"
  828.     ["Show Log of"        sccs-prs        t    nil] ; C-c p
  829.     ["Diff File"        sccs-revert-diff    t    nil] ; C-c d
  830. ;    ["Diff Files"        sccs-version-diff    t]         ; C-c d
  831.     "----"
  832.     ["List Locked Files"    sccs-pending        t]         ; C-c C-p
  833.     ["List Registered Files"    sccs-registered        t]         ; C-c C-r
  834.     ["Diff Directory"        sccs-release-diff    t]
  835.     ["Delta directory"        sccs-delta-release    t]
  836.     ))
  837.  
  838. (progn
  839.   (delete-menu-item '("SCCS"))
  840.   (add-menu '() "SCCS" (cdr sccs-menu)))
  841.  
  842. (defun sccs-sensitize-menu ()
  843.   (let* ((rest (cdr (car (find-menu-item current-menubar '("SCCS")))))
  844.      (case-fold-search t)
  845.      (file (if buffer-file-name
  846.            (file-name-nondirectory buffer-file-name)
  847.          (buffer-name)))
  848.      (dir (file-name-directory
  849.            (if buffer-file-name buffer-file-name default-directory)))
  850.      (sccs-file (and buffer-file-name (sccs-name buffer-file-name)))
  851.      (known-p (and sccs-file (file-exists-p sccs-file)))
  852.      command
  853.      item)
  854.     (while rest
  855.       (setq item (car rest))
  856.       (if (not (vectorp item))
  857.       nil
  858.     (setq command (aref item 1))
  859.     (cond ((eq 'sccs command)
  860.            (aset item 0
  861.              (cond ((or (null sccs-file) (not known-p))
  862.                 "SCCS Create")
  863.                ((not (file-exists-p
  864.                   (sccs-name buffer-file-name "p")))
  865.                 "SCCS Edit")
  866.                (t
  867.                 "SCCS Delta"))))
  868.           ((and (> (length item) 3)
  869.             (string-match "directory" (aref item 0)))
  870.            (aset item 3 dir))
  871.           ((> (length item) 3)
  872.            (aset item 3 file))
  873.           (t nil))
  874.     (aset item 2
  875.           (if (memq command '(sccs sccs-insert-headers sccs-release-diff
  876.                   sccs-version-diff sccs-pending
  877.                   sccs-registered sccs-delta-release))
  878.           t
  879.         known-p)))
  880.       (setq rest (cdr rest))))
  881.   nil)
  882.  
  883. (add-hook 'activate-menubar-hook 'sccs-sensitize-menu)
  884.  
  885. ;; sccs.el ends here
  886.