home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / interfaces / config.shar / config.el next >
Encoding:
Text File  |  1990-07-22  |  55.8 KB  |  1,575 lines
  1. ;;; GENERIC VERSION MANAGEMENT INTERFACE.
  2. ;;;
  3. ;;; This file contains various routines that connect to various
  4. ;;; configuration management tools and various styles of checking in and
  5. ;;; checking out files.  It works with RCS and SCCS.  It can easily be
  6. ;;; extended to work with RCS or SCCS frontends.
  7. ;;;
  8. ;;; No key bindings to the functions are given, because this is a part
  9. ;;; of a larger package of mine.
  10.  
  11. ;;; This software and documentation were written while I, Brian Marick,
  12. ;;; was an employee of Gould Computer Systems.  They have been placed in
  13. ;;; the public domain.  They were extensively rewritten at the University
  14. ;;; of Illinois.
  15.  
  16. ;;; Chris Liebman's dired-rcs provided some of the code for the dired
  17. ;;; interface.
  18.  
  19. (require 'cl)        ; We use CL functions. 
  20. (provide 'config)
  21.  
  22. ;;; Naming conventions (to avoid clashes with other packages).
  23. ;;; Public names begin with "config-".
  24. ;;; Public names used with dired begin with "dired-config-"
  25. ;;; Public names used with the Buffer menu begin with "buffmenu-config"
  26. ;;; Private names begin with "cu-" (short for config-util).
  27. ;;; Names for functions that deal with version control systems begin with
  28. ;;; the names of those systems:  "RCS-", "SCCS-", or "compress-".
  29.  
  30.  
  31. (defconst *config-version* "$Header: /home/src/emacs/custom/lynx/lisp/RCS/config.el,v 1.3 90/05/17 09:57:19 marick Exp $ -- First released version")
  32.  
  33. ;; $Log:    config.el,v $
  34. ;; Revision 1.3  90/05/17  09:57:19  marick
  35. ;; Andy's SCCS-tools-path.
  36. ;; 
  37. ;; Revision 1.2  90/03/13  08:30:15  marick
  38. ;; This version has Buffer Menu commands.
  39. ;; 
  40. ;; Revision 1.1  89/11/14  08:34:24  marick
  41. ;; First released version.
  42. ;; 
  43.  
  44. ;===%%SF%% vars (Start)  ===
  45.  
  46. ;;; Variables the user may want to set:
  47.  
  48. (defvar *config-type* 'SCCS
  49.   "The type of configuration control you use.  Stock ones are
  50.     RCS        use RCS to check in and out of RCS subdirectory.
  51.     SCCS        Use SCCS to check in and out of SCCS subdirectory.
  52. Others are easily added.
  53. ")
  54.  
  55. (defvar *config-verbose-commands* t
  56.   "If T shell-commands are printed into display buffers before being
  57. executed.")
  58.  
  59. (defvar *config-filename-filter-list*
  60.         '(cu-standard-filter cu-query-filter)
  61.     "Whole-directory checkins are pruned by passing lists of files to
  62. successive filters in this list.  See CONFIG-DIR-IN.")
  63.  
  64. (defvar *config-dired-interface* t
  65.   "If T, add these config commands to dired mode:
  66.     l = display the log for the file. (config-log)
  67.     D - show differences between the file and the archive. (config-diff)
  68.     I - check in the file. (config-in)
  69.     O - check out the file. (config-out)
  70.     > - flag this file as ready to be checked in
  71.     < - The same as '>'.
  72.     A - flag all checked-out files.
  73.     X - checkin all marked files."
  74. )
  75.  
  76. (defvar *config-buffmenu-interface* t
  77.   "If T, add these config commands to dired mode:
  78.     l = display the log for the file. (config-log)
  79.     D - show differences between the file and the archive. (config-diff)
  80.     I - check in the file. (config-in)
  81.     O - check out the file. (config-out)
  82.     > - flag this file as ready to be checked in
  83.     < - The same as '>'.
  84.     A - flag all checked-out files.
  85.     X - checkin all marked files."
  86. )
  87.  
  88. ;;; Hack: we choose a large number so as not to conflict with any user
  89. ;;; registers but still allow us to use registers to save previous
  90. ;;; comments.  This lets us merge the automatic saving of old comments
  91. ;;; with the mechanism that makes it easy for the user to retrieve old
  92. ;;; comments at any time.
  93. (defvar *config-comment-register* 52525
  94.   "If set to a character, the log comment message will be copied into the
  95. register with that name.  You can use it when making up later comments.")
  96.  
  97. ;;; A. Glew added this.
  98. (defvar SCCS-tools-path ""
  99.     "Directory where SCCS tools reside - empty if in $PATH, /usr/sccs/ on a SUN, etc.")
  100.  
  101.  
  102. ;;; Variables the user will probably leave alone:
  103.  
  104. (defvar *config-reuse* nil
  105.   "If T and *config-comment-register* contains text, use that text
  106. instead of asking for a comment.  If 'QUERY, use the text only if the
  107. user gives permission.  If NIL, always ask for a comment.")
  108.  
  109. (defconst *config-diff-bufname* "diffs for config"
  110.   "Differences displayed here.")
  111. (defconst *config-log-bufname* "log for config"
  112.   "File change logs displayed here.")
  113. (defconst *config-comment-bufname* "comments for config"
  114.   "Checkin comments gathered here.")
  115. (defconst *config-results-bufname* "results for config"
  116.   "Command results displayed here.")
  117.  
  118. (defconst *config-header-delim* "--text follows this line--")
  119.  
  120. (defconst *config-shell* "/bin/sh"
  121.   "Config uses the Bourne shell for subcommands.  This is its name.")
  122.  
  123. ;;; When we're trying to check in a list of files, we have to use a
  124. ;;; recursive edit, because we want to present one log buffer at a
  125. ;;; time.  Normally, though, we avoid recursive editing, handling
  126. ;;; things more like rmail mode and the like.
  127. (defvar *config-recursing* nil)
  128.  
  129. ;;; The number of seconds to sleep when printing transient message to
  130. ;;; minibuffer.
  131. (defvar *config-sleep* 1)
  132.  
  133. ;===%%SF%% vars (End)  ===
  134.  
  135. ;===%%SF%% macros (Start)  ===
  136. ;;; These have to be here so that the compiler can see them.
  137. ;;; Actually, I suppose the Elisp compiler probably doesn't
  138. ;;; macroexpand at compile time.
  139.  
  140. (defmacro with-buffer (buffer &rest forms)
  141.   "Execute the given FORMS in the given buffer, creating it if
  142. necessary.  The current buffer is restored on exit.  There's no
  143. change in window configuration -- set-buffer is used."
  144.   (let ((saved-buf (gensym)))
  145.     (` (let (( (, saved-buf) (current-buffer)))
  146.         (cu-set-buffer-create (, buffer))
  147.     (unwind-protect (progn (,@ forms))
  148.                     (set-buffer (, saved-buf)))))))
  149.  
  150. ;;; This is used to prevent default directory from getting changed in 
  151. ;;; whatever buffer a command is called from.  It should be used in
  152. ;;; functions that can cause recursive edits.
  153. (defmacro with-function-home (buffer directory &rest forms)
  154.   "Execute the body of the macro inside the given BUFFER, with the
  155. given DIRECTORY as the default-directory of that buffer.  Everything
  156. is restored on exit."
  157.     (let ((saved-dir (gensym)))
  158.       (` (with-buffer (, buffer)
  159.        (let* (( (, saved-dir) default-directory)
  160.           (default-directory (, directory)))
  161.          (unwind-protect (progn (,@ forms))
  162.            (setq default-directory (, saved-dir))))))))
  163.  
  164. ;; So they indent reasonably.
  165. (put 'with-buffer 'lisp-indent-hook 1)
  166. (put 'with-function-home 'lisp-indent-hook 1)
  167.     
  168. ;===%%SF%% macros (End)  ===
  169.  
  170.  
  171.  
  172. ;===%%SF%% interfaces (Start)  ===
  173. ;;; These are the major user interfaces.
  174.  
  175. ;;; Buffer pops up.  Cursor remains in old buffer.
  176. ;;; Current-buffer is unchanged.
  177. (defun config-diff (file)
  178.   "This function shows the differences between a FILE and the most
  179. recent version in its archive file."
  180.   (interactive "FFile: ")
  181.   (cu-assert-system-available)
  182.   (cu-maybe-save-file file)
  183.   (setq file (cu-expand-and-check file 'no-dir))
  184.   (with-buffer *config-diff-bufname*
  185.     (erase-buffer)
  186.     (insert "Diff for " (file-name-nondirectory file) ?\n)
  187.     (if (config-archive-p file)
  188.     (config-shell-command (funcall (cu-get 'diff-command) file))
  189.       (insert "   There is no archive for this file yet.")))
  190.   (display-buffer *config-diff-bufname*))
  191.  
  192.  
  193. (defun config-maybe-make-archive-dir (file)
  194.   "This function checks whether an archive directory for FILE exists.
  195. If not, it will, on request, try to make the directory.
  196. Otherwise, it errors out."
  197.   (interactive "FFile: ")
  198.   (cu-assert-system-available)
  199.   (setq file (cu-expand-and-check file 'no-dir 'missing-ok))
  200.   (funcall (cu-get 'assert-good-filename) file)
  201.   (let ((dirname (funcall (cu-get 'archive-dir) file)))
  202.     (cond ((file-directory-p dirname)
  203.        (if (interactive-p)
  204.            (message "Archive already exists."))
  205.        t)
  206.       ((y-or-n-p "No directory for archive.  Make it? ")
  207.        (shell-command (concat "mkdir " dirname) nil))
  208.       (t
  209.        (error "No directory for archive file.")))))
  210.     
  211. (defun config-archive-p (file)
  212.   "This function returns T if an archive for FILE exists; NIL otherwise."
  213.   (interactive "FFile: ")
  214.   (cu-assert-system-available)
  215.   (setq file (cu-expand-and-check file 'no-dir 'missing-ok))
  216.   (funcall (cu-get 'assert-good-filename) file)
  217.   (let ((retval (file-exists-p (config-archive file))))
  218.     (if (interactive-p)
  219.     (if retval
  220.         (message "Archive exists.")
  221.       (message "Archive does not exist.")))
  222.     retval))
  223.       
  224.  
  225. (defun config-archive (file)
  226.   "This function returns the name of the archive file corresponding to 
  227. FILE.  There's no guarantee that the archive actually exists.
  228. Use CONFIG-ARCHIVE-P to tell."
  229.   (interactive "FFile: ")
  230.   (cu-assert-system-available)
  231.   (setq file (cu-expand-and-check file 'no-dir 'missing-ok))
  232.   (funcall (cu-get 'assert-good-filename) file)
  233.   (let ((retval (funcall (cu-get 'archive-file) file)))
  234.     (if (interactive-p)
  235.     (message retval))
  236.     retval))
  237.  
  238. (defun config-assert-compiled (source extension) 
  239.   "This function checks whether SOURCE with its extension replaced by
  240. EXTENSION is newer than SOURCE. If EXTENSION is not given, it
  241. is taken to be \".o\"."
  242.   (interactive "FSource File: \nsExtension: (.o) ")
  243.   (cu-assert-system-available)
  244.   (setq source (cu-expand-and-check source 'no-dir))
  245.   (if (equal extension "")
  246.       (setq extension ".o"))
  247.   (let ((object (concat (cu-file-basename source) extension)))
  248.     (if (or (not (file-exists-p object))
  249.         (file-newer-than-file-p source object))
  250.     (error "You haven't compiled the file yet."))))
  251.  
  252. ;; On error:  No change in window layout.
  253. ;; On success:  Pop to checked-out file, cursor in that buffer;
  254. ;; display results buffer.
  255. (defun config-out (file)
  256.   "Check out an editable version of FILE.
  257.    A corresponding archive file must exist.  FILE must not already be
  258. checked out.  If FILE is in an Emacs buffer, it must not be modified.
  259. Most version control systems won't check out onto a writable file, but
  260. that's left up to them.
  261.    After the checkout, you'll be visiting the FILE, which will then be
  262. writable."
  263.  
  264.   (interactive "FFile: ")
  265.   (cu-assert-system-available)
  266.   (setq file (cu-expand-and-check file 'no-dir 'missing-ok))
  267.   (funcall (cu-get 'assert-good-filename) file)
  268.   (if (not (config-archive-p file))
  269.       (error "No archive for this file.  Must check in before checking out."))
  270.   (if (config-out-p file)
  271.       (error "The file is already checked out for editing."))
  272.   (let ((file-buffer (get-file-buffer file)))    ; May be nil.
  273.     (if (and file-buffer
  274.          (buffer-modified-p file-buffer))
  275.     (error "The file's buffer is modified -- can't replace with checked out version.")
  276.       (let* ((file-directory (file-name-directory file))
  277.          (command (funcall (cu-get 'checkout-command) file))
  278.          (newfile (funcall (cu-get 'checkout-newfile) file)))
  279.     (cu-prepare-results-buffer file)
  280.     (config-shell-command command)
  281.     (funcall (cu-get 'pop-to-changed-file) newfile)
  282.     (display-buffer *config-results-bufname*)
  283.     (setq buffer-read-only nil)))))
  284.  
  285. (defun config-out-p (file)
  286.   "This function returns T if the FILE is out for editing, NIL if it's
  287. not and an error if it can't tell.  A FILE that doesn't have an archive
  288. file is NOT out for editing, so CONFIG-OUT-P will return NIL.  To
  289. distinguish between these two variants of NIL, use CONFIG-ARCHIVE-P."
  290.   (interactive "FFile: ")
  291.   (cu-assert-system-available)
  292.   (setq file (cu-expand-and-check file nil 'missing-ok))
  293.   (funcall (cu-get 'assert-good-filename) file)
  294.   (let ((retval (funcall (cu-get 'file-out-p) file)))
  295.     (if (interactive-p)
  296.     (if retval
  297.         (message "File is checked out for editing.")
  298.       (message "File is not checked out.")))
  299.     retval))
  300.  
  301. ;;; Buffer pops up.  Cursor remains in old buffer.
  302. ;;; Current-buffer is unchanged.
  303. (defun config-show-out (directory)
  304.   "This function shows you which files are checked out for editing in
  305. DIRECTORY." 
  306.   (interactive (list (file-name-as-directory 
  307.               (read-file-name "Directory: "
  308.                       default-directory default-directory nil))))
  309.   (cu-assert-system-available)
  310.   (with-buffer *config-results-bufname*
  311.     (let* ((filelist  (funcall (cu-get 'out-list) directory)))
  312.       (cu-prepare-results-buffer (concat "Files out in directory " directory "\n"))
  313.       (if filelist
  314.       (cu-filelist-in-buffer filelist *config-results-bufname*)
  315.     (insert "<<< No files are checked out >>>")))
  316.     (display-buffer *config-results-bufname*)))
  317.   
  318.  
  319. ;; On error:  No change in window layout.
  320. ;; On success:  Pop to reverted file; display results buffer.
  321. ;; Note:  if a comment is being gathered, it and its buffer are thrown
  322. ;; away -- that's often the point at which you decide to undo.
  323. (defun config-undo-out (file)
  324.   "This function undoes the effect of CONFIG-OUT:  The file is reverted
  325. to the version in the archive file, and the file is made read-only.
  326.   Any changes made to the file are lost.
  327.   The function signals an error if the file isn't out for editing, or
  328. if there is no archive file."
  329.   (interactive "FFile: ")
  330.   (cu-assert-system-available)
  331.   (setq file (cu-expand-and-check file 'no-dir))
  332.   (funcall (cu-get 'assert-good-filename) file)
  333.   (if (not (config-archive-p file))
  334.       (error "No archive for this file, so it can't ever have been checked out."))
  335.   (if (not (config-out-p file))
  336.       (error "The file hasn't been checked out for editing."))
  337.  
  338.   ;; Any pending comment is now irrelevant.
  339.   (if (get-buffer *config-comment-bufname*)
  340.       (kill-buffer *config-comment-bufname*))
  341.  
  342.   (let* ((command (funcall (cu-get 'undo-out-command) file)))
  343.     (cu-prepare-results-buffer file)
  344.     (config-shell-command command)
  345.     (funcall (cu-get 'pop-to-changed-file) file)
  346.     (display-buffer *config-results-bufname*)
  347.     (setq buffer-read-only t)))
  348.  
  349.   
  350. ;; Normally:  diff buffer and comment buffer pop up.  Cursor in
  351. ;; comment buffer.
  352. ;; Checkin in progress:  current comment buffer pops up.  
  353. ;;   If they want to continue that checkin, cursor to the comment buffer.
  354. ;;   Otherwise, just like ordinary checkin.
  355. ;; File not checked out:  No change in display.
  356. ;; Comment log to be reused?
  357. ;;   When question asked:  Diff buffer pops up.  Cursor stays behind.
  358. ;;   If no:  Like ordinary checkin.
  359. ;;   If yes: the diff buffer will go away.  The results buffer will be
  360. ;;   visible.
  361. (defun config-in (file)
  362.   "This function allows you to check in a FILE.
  363.    If you're editing the file, it's saved before being checked in.
  364.    This function displays two buffers.  One shows the differences between
  365. the checked-out version of the file and the most recent version in the
  366. archive. You should type comments (for the archive log) in the other
  367. buffer.  When finished, type ^C^C to continue with the checkin.
  368.    If you were visiting the file before checkin, you'll still be in it
  369. after checkin, except that the file will be in synch with the archive
  370. copy and it will be read-only.
  371.    The archive need not exist to check in the file.  It will be created.
  372. "
  373.   (interactive "FFile: ")
  374.   (cu-assert-system-available)
  375.   (cu-maybe-save-file file)
  376.   (setq file (cu-expand-and-check file 'no-dir))
  377.   (funcall (cu-get 'assert-good-filename) file)
  378.  
  379.   ;; First do the error checking
  380.   (if (and (config-archive-p file)
  381.        (not (config-out-p file)))
  382.       (error "File isn't checked out for editing."))
  383.  
  384.   (config-maybe-make-archive-dir file)
  385.  
  386.   ;; We may want to abort an in-progress checkin.
  387.   (when (or (not (config-checking-in-p))
  388.         (progn
  389.           (pop-to-buffer *config-comment-bufname*)
  390.           (y-or-n-p "Already checking in a file.  Forget that checkin? ")))
  391.  
  392.     ;; If there's no previous text, *config-reuse* might as well be NIL.
  393.     (let ((*config-reuse*
  394.        (if (get-register *config-comment-register*)
  395.            *config-reuse*
  396.          nil)))
  397.          
  398.       (when (not (eq *config-reuse* t))
  399.     ;; They have to think about what they've done -- show it.
  400.     (config-diff file))
  401.  
  402.       (when (eq *config-reuse* 'QUERY)
  403.     ;; Promote or demote *config-reuse* according to what they decide.
  404.     (view-register *config-comment-register*)
  405.     (switch-to-buffer *config-diff-bufname*)
  406.     (setq *config-reuse*
  407.           (y-or-n-p (format "Reuse previous comment in this file, %s? "
  408.                 (file-name-nondirectory file)))))
  409.  
  410.       ;; At this point, one of two things can happen.  If there's a
  411.       ;; previous log message to reuse, we just hand the file and the
  412.       ;; previous message to CU-DO-CHECKIN.  If not, we create the comment
  413.       ;; buffer.  When the user types ^C^C there, the resulting function
  414.       ;; (CONFIG-FINISH-CHECKIN) will call CU-DO-CHECKIN.
  415.       (if *config-reuse*
  416.       (cu-do-checkin file (get-register *config-comment-register*))
  417.     (cu-display-two-buffers *config-comment-bufname*
  418.                 *config-diff-bufname*)
  419.     (cu-checkin-mode)
  420.     ;; We need to stash the file in the buffer so that we can 
  421.     ;; retrieve it when the user types C-c C-c.
  422.     (make-local-variable 'checkin-file)
  423.     (setq checkin-file file)
  424.     (erase-buffer)
  425.     (insert "Log comment for " file "\n")
  426.     (insert *config-header-delim* "\n")
  427.     (message "Type in the log comment; end with ^C^C.")
  428.     (if *config-recursing*
  429.         (recursive-edit))))))
  430.  
  431.  
  432. (defun config-kill-checkin ()
  433.   "This command stops any in-progress checkins, undoing the effects of
  434. CONFIG-IN or CONFIG-DIR-IN."
  435.   (interactive)
  436.   (cu-assert-system-available)
  437.   (if (get-buffer *config-comment-bufname*)
  438.       (kill-buffer *config-comment-bufname*))
  439.   ;; Top level gets us out of recursive edits and clears *config-recursing*.
  440.   (when *config-recursing*
  441.     (cu-results-logit "***Checkin cancelled***")
  442.     (throw 'list-checkin-tag nil)))
  443.  
  444.  
  445. ;; Buffer pops up.  Cursor remains in old buffer.
  446. ;;; Current-buffer is unchanged.
  447. (defun config-log (file)
  448.   "This file shows the log file for the given FILE."
  449.   (interactive "FFile: ")
  450.   (cu-assert-system-available)
  451.   (setq file (cu-expand-and-check file 'no-dir 'missing-ok))
  452.   (with-buffer *config-log-bufname*
  453.     (erase-buffer)
  454.     (insert "Log for " file ".\n")
  455.     (if (config-archive-p file)
  456.     (config-shell-command (funcall (cu-get 'log-command) file))
  457.       (insert "There is no archive.\n")))
  458.   (display-buffer *config-log-bufname*))
  459.  
  460.  
  461. (defun config-version ()
  462.   "Display the version number."
  463.   (interactive)
  464.   (message *config-version*))
  465.  
  466. ;   ===%%SF%% interfaces/group (Start)  ===
  467. (defun config-all-in (directory)
  468.   "This routine calls CONFIG-IN on all the checked-out files in the
  469. DIRECTORY. You'll be given the option of using the previous file's log
  470. message on each new file."
  471.   ;; The interactive 'D' option doesn't do quite the right thing -- RET
  472.   ;; often gives you a file, not a directory.
  473.   (interactive (list (file-name-as-directory 
  474.               (read-file-name "Directory: "
  475.                       default-directory default-directory nil))))
  476.   (cu-assert-system-available)
  477.  
  478.   (with-function-home *config-results-bufname* directory
  479.      (when (not (cu-duplicate-checkin-p))
  480.        (let ((filelist (funcall (cu-get 'out-list) directory))
  481.          (*config-reuse* 'QUERY))
  482.      (cu-prepare-results-buffer "Checking in checked-out files.")
  483.      (cu-list-in (cu-query-filter filelist))))))
  484.  
  485.  
  486. (defun config-buffers-in ()
  487.   "This routine calls CONFIG-IN on all the checked-out files currently being 
  488. edited.  You'll be given the option of using the previous file's log
  489. message on each new file."
  490.   (interactive)
  491.  
  492.   (cu-assert-system-available)
  493.   (with-function-home *config-results-bufname* default-directory
  494.      (when (not (cu-duplicate-checkin-p))
  495.        (let ((filelist (cu-outness-filter (config-buffmenu-filelist)))
  496.          (*config-reuse* 'QUERY))
  497.      (cu-prepare-results-buffer "Checking in checked-out buffers.")
  498.      (cu-list-in (cu-query-filter filelist))))))
  499.  
  500.  
  501. ;;; During intermediate checkins:
  502. ;;;   Same rules as config-in:  comment log in one window, diff in the other.
  503. ;;; At end:
  504. ;;;   The results buffer is the only buffer visible.
  505. (defun config-dir-in (directory)
  506.   "This routine calls CONFIG-IN on the files in the DIRECTORY
  507. argument.  You'll be given the option of using the previous file's log
  508. message on each new file.
  509.  
  510. These kinds of files are never checked in:
  511. - Directories.
  512. - Backup and auto-save files.
  513. - C object files (ending in .o)
  514. - Library files (ending in .a)
  515. - Compressed files (ending in .Z or .z)
  516. - Compiled elisp files (ending in .elc)
  517. - Files with archive files that are not checked out for editing.
  518.  
  519. Exception:  If the file indeed has an archive file, and is checked
  520. out for editing, it will be checked in regardless of its name.
  521.  
  522. If a file has no archive file, you'll be asked whether you want to
  523. check the file in (thus creating an archive).
  524.  
  525. All of these rules can be overridden by modifying
  526. *config-filename-filter-list*." 
  527.  
  528.   ;; The interactive 'D' option doesn't do quite the right thing -- RET
  529.   ;; often gives you a file, not a directory.
  530.   (interactive (list (file-name-as-directory 
  531.               (read-file-name "Directory: "
  532.                       default-directory default-directory nil))))
  533.   (cu-assert-system-available)
  534.  
  535.   ;; Save buffers in case there's an edited file that doesn't have an
  536.   ;; on-disk image yet.
  537.   (save-some-buffers)
  538.  
  539.   (with-function-home *config-results-bufname* directory
  540.      (when (not (cu-duplicate-checkin-p))
  541.        (cu-prepare-results-buffer "Checking in a list of files.")
  542.        (let* ((filelist
  543.            (cu-apply-file-filters (directory-files directory 'full)))
  544.           (*config-reuse* *config-reuse*))
  545.      (if (and (> (length filelist) 1)
  546.           (yes-or-no-p
  547.            "Should the first comment be silently used for all files? "))
  548.          (setq *config-reuse* t)
  549.        (setq *config-reuse* 'QUERY))
  550.      (cu-list-in filelist)))))
  551.  
  552. ;   ===%%SF%% interfaces/group (End)  ===
  553.  
  554. ;   ===%%SF%% interfaces/dired (Start)  ===
  555. ;;;   DIRED interface.  Some code and ideas stolen from Chris Liebman.
  556.  
  557.  
  558. ;;; Push our setup function on the dired-mode hook. 
  559. (cond ((not (boundp 'dired-mode-hook))
  560.        (setq dired-mode-hook 'dired-config-setup))
  561.       ((listp dired-mode-hook)
  562.        (push 'dired-config-setup dired-mode-hook))
  563.       (t
  564.        (setq dired-mode-hook
  565.          (list 'dired-config-setup dired-mode-hook))))
  566.  
  567. ;;; Note that you can set *config-dired-interface* at any time.
  568. ;;; Any direds after that will have dired-config key bindings.
  569. (defun dired-config-setup ()
  570.   "Setup config key bindings for dired."
  571.   (when *config-dired-interface*
  572.     (local-set-key "l" 'dired-config-log)
  573.     (local-set-key "D" 'dired-config-diff)
  574.     (local-set-key "I" 'dired-config-in)
  575.     (local-set-key "O" 'dired-config-out)
  576.     (local-set-key ">" 'dired-config-flag-file-for-checkin)
  577.     (local-set-key "<" 'dired-config-flag-file-for-checkin)
  578.     (local-set-key "A" 'dired-config-flag-all-out)
  579.     (local-set-key "X" 'dired-config-checkin-flagged-files)))
  580.  
  581. ;;;
  582. ;;; Dired commands.
  583. ;;;
  584.  
  585. (defun dired-config-out ()
  586.   "In dired, call CONFIG-OUT to check out a file."
  587.   (interactive)
  588.   (cu-assert-system-available)
  589.   (let* ((filename (dired-get-filename)))
  590.     (config-out filename)))
  591.  
  592. (defun dired-config-in ()
  593.   "In dired, call CONFIG-IN to check in a file."
  594.   (interactive)
  595.   (cu-assert-system-available)
  596.   (let ((filename (dired-get-filename)))
  597.     (config-in filename)))
  598.  
  599. (defun dired-config-log ()
  600.   "In dired, call CONFIG-LOG to show a file's archive log."
  601.   (interactive)
  602.   (cu-assert-system-available)
  603.   (config-log (dired-get-filename)))
  604.  
  605. (defun dired-config-diff ()
  606.   "In dired, diff the working file against the latest checked in one."
  607.   (interactive)
  608.   (cu-assert-system-available)
  609.   (config-diff (dired-get-filename)))
  610.  
  611. (defun dired-config-flag-file-for-checkin (arg)
  612.   "In dired, mark a file for checkin.  'X' performs the checkin.
  613. With arg, repeat over ARG lines"
  614.   (interactive "p")
  615.   (cu-assert-system-available)
  616.   (let ((buffer-read-only nil))
  617.     (dired-repeat-over-lines arg
  618.       '(lambda ()
  619.      (let* ((file (dired-get-filename))
  620.         (is-archive-file (config-archive-p file)))
  621.        (if (and is-archive-file
  622.             (not (config-out-p file)))
  623.            (error "File is not checked out for editing")
  624.          (if (not is-archive-file)
  625.          (message "Note: file has no archive."))
  626.          (let ((buffer-read-only nil))
  627.            (delete-char 1)
  628.            (insert "<"))))))))
  629.  
  630.  
  631. ;; Note:  calling dired-config-flag-file-for-checkin is gross wastage.
  632. ;; It does much unnecessary checking.
  633. ;; Someday clean this up to be a simple traversal of the dired buffer.
  634. (defun dired-config-flag-all-out ()
  635.   "In dired, check in all the checked-out file in the directory."
  636.   (interactive)
  637.   (cu-assert-system-available)
  638.   (let ((filelist (funcall (cu-get 'out-list) default-directory)))
  639.     (dolist (file (mapcar 'file-name-nondirectory filelist))
  640.       (beginning-of-buffer)    ; Love them O(n^2) algorithms
  641.       (if (re-search-forward (concat " " file "$") nil t)
  642.       (dired-config-flag-file-for-checkin 1)
  643.     (error "Checked out file not in dired list -- dired buffer out of date?")))
  644.     (if (null filelist)
  645.     (message "No files checked out."))))
  646.     
  647.  
  648. ;; Note:  we delete the flags only after the file list passes the
  649. ;; query filter.  That's so the user can reject the list of files and
  650. ;; go edit it (by flagging/unflagging more files).
  651. (defun dired-config-checkin-flagged-files ()
  652.   "In dired, checkin all the files that have been flagged for checkin."
  653.   (interactive)
  654.   (cu-assert-system-available)
  655.   (let ((file-list nil)
  656.     (buffer-read-only nil)
  657.     (*config-reuse* 'QUERY))
  658.     (save-excursion
  659.       (goto-char 1)
  660.       (while (re-search-forward "^<" nil t)
  661.     (push (dired-get-filename) file-list)))
  662.     (setq file-list (nreverse file-list))
  663.     (with-function-home *config-results-bufname* default-directory
  664.       (when (not (cu-duplicate-checkin-p))
  665.     (cu-prepare-results-buffer "Checking in from DIRED")
  666.     (setq file-list (cu-query-filter file-list))
  667.     (when file-list
  668.       (save-excursion
  669.         (goto-char 1)
  670.         (while (re-search-forward "^<" nil t)
  671.           (delete-char -1)
  672.           (insert " ")))
  673.       (cu-list-in file-list))))))
  674.  
  675. ;   ===%%SF%% interfaces/dired (End)  ===
  676.  
  677.  
  678. ;   ===%%SF%% interfaces/buffmenu (Start)  ===
  679. ;;;   Buffer menu interface
  680.  
  681.  
  682. ;      ===%%SF%% interfaces/buffmenu/initialization (Start)  ===
  683.  
  684. ;;; Push our setup function on the buffer-menu-mode hook. 
  685. (cond ((not (boundp 'buffer-menu-mode-hook))
  686.        (setq buffer-menu-mode-hook 'buffmenu-config-setup))
  687.       ((listp buffer-menu-mode-hook)
  688.        (push 'buffmenu-config-setup buffer-menu-mode-hook))
  689.       (t
  690.        (setq buffer-menu-mode-hook
  691.          (list 'buffmenu-config-setup buffer-menu-mode-hook))))
  692.  
  693. ;;; Note that you can set *config-buffmenu-interface* at any time.
  694. ;;; Any buffmenus after that will have buffmenu-config key bindings.
  695. (defun buffmenu-config-setup ()
  696.   "Setup config key bindings for buffmenu."
  697.   (when *config-buffmenu-interface*
  698.     (local-set-key "l" 'buffmenu-config-log)
  699.     (local-set-key "D" 'buffmenu-config-diff)
  700.     (local-set-key "I" 'buffmenu-config-in)
  701.     (local-set-key "O" 'buffmenu-config-out)
  702.     (local-set-key ">" 'buffmenu-config-flag-file-for-checkin)
  703.     (local-set-key "<" 'buffmenu-config-flag-file-for-checkin)
  704.     (local-set-key "A" 'buffmenu-config-flag-all-out)
  705.     (local-set-key "X" 'buffmenu-config-checkin-flagged-files)))
  706.  
  707. ;      ===%%SF%% interfaces/buffmenu/initialization (End)  ===
  708.  
  709. ;      ===%%SF%% interfaces/buffmenu/util (Start)  ===
  710.  
  711. (defun config-buffmenu-on-header-p ()
  712.   (save-excursion
  713.     (beginning-of-line)
  714.     (or (looking-at " MR Buffer")
  715.     (looking-at " -- ------"))))
  716.  
  717. (defun config-buffmenu-file-name (verbose)
  718.   "Return the filename of the current line, NIL if buffer has no file."
  719.   (save-excursion
  720.     (if (config-buffmenu-on-header-p)
  721.     (error "No buffer on this line."))
  722.     (let ((buffer (Buffer-menu-buffer nil))
  723.       file-name)
  724.       (cond ((null buffer)
  725.          (if verbose (message "Buffer has been deleted."))
  726.          nil)
  727.         ((setq file-name (buffer-file-name buffer))
  728.          file-name)
  729.         (t
  730.          (if verbose (message "No file for this buffer."))
  731.          nil)))))
  732.  
  733. ;;; Return a list of filenames corresponding to active buffers.
  734. ;;; The list of buffers is available only from the Buffer menu buffer.
  735. ;;; We don't change the buffer menu out from under the user, even
  736. ;;; though the menu may be out of date.  If we have to create the
  737. ;;; buffer menu, we destroy it later.
  738. (defun config-buffmenu-filelist ()
  739.   (let ((created-menu-p (not (get-buffer "*Buffer List*")))
  740.     (current-buf (current-buffer)))
  741.     (when created-menu-p
  742.     (list-buffers 'files-only))
  743.     (set-buffer "*Buffer List*")
  744.     (save-excursion
  745.       (beginning-of-buffer)
  746.       (next-line 2)
  747.       (let ((filelist nil)
  748.         (result nil))
  749.     (while (not (eobp))
  750.       (setq result (config-buffmenu-file-name nil))
  751.       (if result (push result filelist))
  752.       (forward-line 1))
  753.     (if created-menu-p
  754.         (kill-buffer "*Buffer List*"))
  755.     (set-buffer current-buf)
  756.     (nreverse filelist)))))
  757.  
  758.  
  759. ;; Like dired, except ARG must be positive.
  760. (defun buffmenu-config-repeat-over-lines (arg function)
  761.   (beginning-of-line)
  762.   (if (config-buffmenu-on-header-p)
  763.       (error "No file on this line"))
  764.   (while (and (> arg 0) (not (eobp)))
  765.     (setq arg (1- arg))
  766.     (save-excursion
  767.       (beginning-of-line)
  768.       (funcall function))
  769.     (forward-line 1)))
  770.  
  771.  
  772. ;      ===%%SF%% interfaces/buffmenu/util (End)  ===
  773.  
  774.  
  775. (defun buffmenu-config-out ()
  776.   "In the Buffer Menu, call CONFIG-OUT to check out a file."
  777.   (interactive)
  778.   (cu-assert-system-available)
  779.   (let* ((filename (config-buffmenu-file-name 'verbose)))
  780.     (if filename (config-out filename))))
  781.  
  782. (defun buffmenu-config-in ()
  783.   "In the Buffer Menu, call CONFIG-IN to check in a file."
  784.   (interactive)
  785.   (cu-assert-system-available)
  786.   (let ((filename (config-buffmenu-file-name 'verbose)))
  787.     (if filename (config-in filename))))
  788.  
  789. (defun buffmenu-config-log ()
  790.   "In the Buffer Menu, call CONFIG-LOG to show a file's archive log."
  791.   (interactive)
  792.   (cu-assert-system-available)
  793.   (let ((filename (config-buffmenu-file-name 'verbose)))
  794.     (if filename (config-log filename))))
  795.  
  796. (defun buffmenu-config-diff ()
  797.   "In the Buffer Menu, diff the working file against the latest checked in one."
  798.   (interactive)
  799.   (cu-assert-system-available)
  800.   (let ((filename (config-buffmenu-file-name 'verbose)))
  801.     (if filename (config-diff filename))))
  802.  
  803. ;;; Note that the position of point moves forward ARG lines.
  804. (defun buffmenu-config-flag-file-for-checkin (arg)
  805.   "In the Buffer Menu, mark a file for checkin.  'X' performs the checkin.
  806. With arg, repeat over ARG lines."
  807.   (interactive "p")
  808.   (cu-assert-system-available)
  809.   (let ((buffer-read-only nil)
  810.     (be-verbose (= arg 1))) ;; Warnings confusing if arg is, say, 4.
  811.     (buffmenu-config-repeat-over-lines arg
  812.       '(lambda ()
  813.      (let ((file (config-buffmenu-file-name be-verbose)))
  814.        (if file
  815.           (let ((is-archive-file (config-archive-p file)))
  816.         (if (and is-archive-file
  817.              (not (config-out-p file)))
  818.             (error "File is not checked out for editing")
  819.           (if (not is-archive-file)
  820.               (message "Note: file has no archive."))
  821.           (let ((buffer-read-only nil))
  822.             (delete-char 1)
  823.             (insert "I"))))))))))
  824.  
  825.  
  826. ;; Note:  calling buffmenu-config-flag-file-for-checkin is gross wastage.
  827. ;; It does much unnecessary checking.  
  828. (defun buffmenu-config-flag-all-out ()
  829.   "In the Buffer Menu, check in all the checked-out buffers."
  830.   (interactive)
  831.   (cu-assert-system-available)
  832.   (save-excursion
  833.     (beginning-of-buffer)
  834.     (next-line 2)
  835.     (let ((file))
  836.       (while (not (eobp))
  837.     (setq file  (config-buffmenu-file-name nil))
  838.     (if (and file (config-out-p file))
  839.         ;; Kludge -- this does a forward-line.
  840.         (buffmenu-config-flag-file-for-checkin 1)
  841.       (forward-line 1)))))
  842.   (message "Done"))
  843.     
  844.  
  845. ;; Note:  we delete the flags only after the file list passes the
  846. ;; query filter.  That's so the user can reject the list of files and
  847. ;; go edit it (by flagging/unflagging more files).
  848. ;;
  849. ;; Note:  If they flag files, then delete them, then execute the flags,
  850. ;; they lose.  Not worth checking for.
  851. (defun buffmenu-config-checkin-flagged-files ()
  852.   "In the Buffer Menu, check in all the files that have been flagged for checkin."
  853.   (interactive)
  854.   (cu-assert-system-available)
  855.   (let ((file-list nil)
  856.     (buffer-read-only nil)
  857.     (*config-reuse* 'QUERY))
  858.     (save-excursion
  859.       (goto-char 1)
  860.       (while (re-search-forward "^I" nil t)
  861.     (push (config-buffmenu-file-name nil) file-list)))
  862.     (setq file-list (nreverse file-list))
  863.     (with-function-home *config-results-bufname* default-directory
  864.       (when (not (cu-duplicate-checkin-p))
  865.     (cu-prepare-results-buffer "Checking in from Buffer Menu")
  866.     (setq file-list (cu-query-filter file-list))
  867.     (when file-list
  868.       (save-excursion
  869.         (goto-char 1)
  870.         (while (re-search-forward "^I" nil t)
  871.           (delete-char -1)
  872.           (insert " ")))
  873.       (cu-list-in file-list))))))
  874.  
  875. ;   ===%%SF%% interfaces/buffmenu (End)  ===
  876.   
  877. ;===%%SF%% interfaces (End)  ===
  878.  
  879.  
  880. ;===%%SF%% generics (Start)  ===
  881.  
  882. ;;; A variety of generic commands are specialized according to the
  883. ;;; *config-type*.  They are:
  884. ;;;
  885. ;;; checkout-command:  Return a command that checks out an editable version
  886. ;;;    of a file.
  887. ;;; checkout-newfile:  The name of the file after checked out.  (For
  888. ;;;     RCS and SCCS, it's the same -- but that might not be the case
  889. ;;;    for protocols where the file is checked out into a "work"
  890. ;;;     directory.)
  891. ;;; undo-out-command:  Undo the checkout-command.
  892. ;;; checkin-command:  Return a command that checks in a version of a file.
  893. ;;;     It takes the file and a comment for the archive log as arguments.
  894. ;;; pop-to-changed-file:  Visit the just-checked-out/in file.  Make
  895. ;;;     sure it's in synch with the disk version.  
  896. ;;; massage-comment:  Massage the comment so it's suitable for handing to a 
  897. ;;;     checkin command.
  898. ;;; archive-dir:  Given a filename, return the directory where its
  899. ;;;     archive would be.
  900. ;;; archive-file:  Given a filename, return the full pathname for its
  901. ;;;     archive. 
  902. ;;; file-out-p:  Returns the filename if the file is checked out for
  903. ;;;     editing; NIL otherwise.  Should return NIL if there's no archive
  904. ;;;    file.
  905. ;;; out-list:  Returns a list of which files are
  906. ;;;     checked out for editing.  Files should be full pathnames.
  907. ;;; log-command:  Return a command that can be used to print the
  908. ;;;     log for a given file.
  909. ;;; diff-command:  Return a command that diffs the FILE against the
  910. ;;;     top version in the archive.
  911. ;;; assert-good-filename:  Error out if the filename is bad for some
  912. ;;;    reason (typically if the name is too long).
  913. ;;; sample-executable:  An executable in this version-control system.
  914. ;;;     Used to see if the system actually exists on this machine.
  915. ;;;     If it doesn't, you want to abort immediately, not after the user's
  916. ;;;     typed a huge long log comment
  917.  
  918. ;   ===%%SF%% generics/interfaces (Start)  ===
  919. ;;; Each of the config-types has various functions attached to its property
  920. ;;; list.  These are manipulated by these functions:
  921.  
  922. (defun cu-add (config-type generic-name specific-name)
  923.   (put config-type generic-name specific-name))
  924.  
  925. (defun cu-get (function-name)
  926.   (let ((result (get *config-type* function-name)))
  927.     (if (not result)
  928.     (error "Program error -- cu-get: No function %s.  Is *config-type* correct?"
  929.            (symbol-name function-name)))
  930.     result))
  931. ;   ===%%SF%% generics/interfaces (End)  ===
  932.  
  933. ;   ===%%SF%% generics/util (Start)  ===
  934. ;;; These are used with several different CM programs.
  935.  
  936. (defun cu-checkout-newfile (file)
  937.   file)
  938.  
  939. ;; Don't freshly visit a new file if we're recursing -- this is just
  940. ;; one of many being processed.  DO revert the file, since we want
  941. ;; them to be in synch.
  942.  
  943. (defun cu-pop-to-changed-file (file)
  944.   (let ((file-buffer (get-file-buffer file)))
  945.     (cond (file-buffer
  946.        (pop-to-buffer file-buffer)
  947.        (revert-buffer 'no-auto-save 'no-confirm))
  948.       ((not *config-recursing*)
  949.        (find-file-other-window file)))))
  950.  
  951. ;; Escape quotes and slashes.
  952. ;; The different shells treat newlines in quoted strings differently.
  953. ;; They also treat slashes within quoted strings differently.
  954. ;; Rather than anticipating all possible shells, we'll assume /bin/sh.
  955. (defun cu-massage-comment ()
  956.   (beginning-of-buffer) (replace-regexp "\\\\" "\\\\\\\\")
  957.   (beginning-of-buffer) (replace-regexp "\"" "\\\\\""))
  958.  
  959. ;;; Any filename is good on BSD.  (We don't check for pathname limits.)
  960. ;;; On system V, a file must have 2 characters free for an archive tag
  961. ;;; (the "s." prefix for SCCS, or the ",v" suffix for RCS).
  962. (defun cu-assert-good-filename (file)
  963.   (let ((basename (file-name-nondirectory file)))
  964.     (if (and (eq system-type 'usg-unix-v)
  965.          (>= (length basename) 13))
  966.     (cond ((eq *config-type* 'SCCS)
  967.            (error "%s is too long for the archive prefix 's.'"
  968.               basename))
  969.           ((eq *config-type* 'RCS)
  970.            (error "%s is too long for the archive suffix ',v'"
  971.               basename))
  972.           (t
  973.            (error "Program error: cu-assert-good-filename called with bad *config-type*"))))))
  974.  
  975. ;   ===%%SF%% generics/util (End)  ===
  976.  
  977.  
  978. ;   ===%%SF%% generics/SCCS (Start)  ===
  979.  
  980. (defun SCCS-checkout-command (file)
  981.   (let ((file-directory (directory-file-name (file-name-directory file))))
  982.     (concat "cd " file-directory "; " SCCS-tools-path "get -e SCCS/s."
  983.         (file-name-nondirectory file))))
  984.  
  985. (cu-add 'SCCS 'checkout-command 'SCCS-checkout-command)
  986.  
  987.  
  988. ;; Note -- use a delta followed by an explicit get, instead of delta -n,
  989. ;; because delta -n leaves the file editable.
  990. (defun SCCS-checkin-command (file comment)
  991.   (let ((file-directory (directory-file-name (file-name-directory file)))
  992.     (name (file-name-nondirectory file)))
  993.     (if (config-archive-p file)
  994.     (concat "cd " file-directory "; "
  995.         SCCS-tools-path "delta -y\"" comment "\" SCCS/s." name "; "
  996.         SCCS-tools-path "get SCCS/s." name)
  997.       (concat "cd " file-directory "; "
  998.           SCCS-tools-path "admin -i" file " -y\"" comment "\" SCCS/s." name "; "
  999.           "/bin/rm " name " ; "
  1000.           SCCS-tools-path "get SCCS/s." name))))
  1001.  
  1002. (cu-add 'SCCS 'checkin-command 'SCCS-checkin-command)
  1003.  
  1004.  
  1005. (defun SCCS-diff-command (file)
  1006.   (let ((file-directory (directory-file-name (file-name-directory file)))
  1007.     (file-only (file-name-nondirectory file)))
  1008.     (concat "cd " file-directory ";"
  1009.             SCCS-tools-path "get -p SCCS/s." file-only " > /tmp/ci$$;"
  1010.         "diff " file-only " /tmp/ci$$;"
  1011.         "/bin/rm /tmp/ci$$")))
  1012.  
  1013. (cu-add 'SCCS 'diff-command 'SCCS-diff-command)
  1014.  
  1015.  
  1016. (defun SCCS-log-command (file)
  1017.   (let ((file-directory (directory-file-name (file-name-directory file)))
  1018.     (file-only (file-name-nondirectory file)))
  1019.     (concat "cd " file-directory ";"
  1020.         SCCS-tools-path "prs SCCS/s." file-only)))
  1021. (cu-add 'SCCS 'log-command 'SCCS-log-command)
  1022.   
  1023.  
  1024. (defun SCCS-archive-dir (file)
  1025.   (concat (file-name-directory file) "SCCS"))
  1026. (cu-add 'SCCS 'archive-dir 'SCCS-archive-dir)
  1027.  
  1028. (defun SCCS-archive-file (file)
  1029.   (concat (file-name-as-directory (SCCS-archive-dir file))
  1030.       "s."
  1031.       (file-name-nondirectory file)))
  1032. (cu-add 'SCCS 'archive-file 'SCCS-archive-file)
  1033.  
  1034. (defun SCCS-file-out-p (file)
  1035.   (file-exists-p
  1036.      (concat (file-name-as-directory (SCCS-archive-dir file))
  1037.       "p."
  1038.       (file-name-nondirectory file))))
  1039. (cu-add 'SCCS 'file-out-p 'SCCS-file-out-p)
  1040.  
  1041. (defun SCCS-out-list (dir)
  1042.   (let* ((dir (file-name-as-directory dir))
  1043.      (command (concat "cd " dir "SCCS\nls p.*"))
  1044.      (list nil))
  1045.     (with-buffer " *config show out buffer*"
  1046.       (erase-buffer)
  1047.       (let ((shell-file-name *config-shell*))
  1048.     (shell-command command t))
  1049.       (beginning-of-buffer)
  1050.       (while (re-search-forward "^p\\.\\(.*\\)$" nil t)
  1051.     (push (cu-make-full-path dir
  1052.                  (buffer-substring (match-beginning 1)
  1053.                            (match-end 1)))
  1054.           list))
  1055.       (cond ((null list)
  1056.          nil)
  1057.         ((not (file-exists-p (car list)))
  1058.          nil)                ; Must be an error message
  1059.         (t
  1060.          (nreverse list))))))
  1061. (cu-add 'SCCS 'out-list 'SCCS-out-list)
  1062.  
  1063. (defun SCCS-undo-out-command (file)
  1064.   (let ((file-directory (directory-file-name (file-name-directory file)))
  1065.     (file-only (file-name-nondirectory file)))
  1066.     (concat "cd " file-directory ";"
  1067.         "/bin/rm -f SCCS/p." file-only ";"
  1068.         "/bin/rm -f " file-only ";"
  1069.         SCCS-tools-path "get SCCS/s." file-only)))
  1070. (cu-add 'SCCS 'undo-out-command 'SCCS-undo-out-command)
  1071.  
  1072. (cu-add 'SCCS 'checkout-newfile 'cu-checkout-newfile)
  1073. (cu-add 'SCCS 'pop-to-changed-file 'cu-pop-to-changed-file)
  1074. (cu-add 'SCCS 'massage-comment 'cu-massage-comment)
  1075. (cu-add 'SCCS 'assert-good-filename 'cu-assert-good-filename)
  1076.  
  1077. (cu-add 'SCCS 'sample-executable (concat SCCS-tools-path "prs"))
  1078.  
  1079. ;   ===%%SF%% generics/SCCS (End)  ===
  1080.  
  1081. ;   ===%%SF%% generics/RCS (Start)  ===
  1082.  
  1083. (defun RCS-checkout-command (file)
  1084.   (let ((file-directory (directory-file-name (file-name-directory file))))
  1085.     (concat "cd " file-directory "; co -l "
  1086.         (file-name-nondirectory file))))
  1087. (cu-add 'RCS 'checkout-command 'RCS-checkout-command)
  1088.  
  1089. (defun RCS-checkin-command (file comment)
  1090.   (let ((file-directory (directory-file-name (file-name-directory file))))
  1091.     (concat "cd " file-directory "; ci -u -f -m\"" comment "\" "
  1092.         (file-name-nondirectory file))))
  1093. (cu-add 'RCS 'checkin-command 'RCS-checkin-command)
  1094.  
  1095. (defun RCS-log-command (file)
  1096.   (let ((file-directory (directory-file-name (file-name-directory file))))
  1097.     (concat "cd " file-directory "; rlog "
  1098.         (file-name-nondirectory file))))
  1099. (cu-add 'RCS 'log-command 'RCS-log-command)
  1100.  
  1101. (defun RCS-archive-dir (file)
  1102.   (concat (file-name-directory file) "RCS"))
  1103. (cu-add 'RCS 'archive-dir 'RCS-archive-dir)
  1104.  
  1105. (defun RCS-archive-file (file)
  1106.   (concat (file-name-as-directory (RCS-archive-dir file))
  1107.       (file-name-nondirectory file)
  1108.       ",v"))
  1109. (cu-add 'RCS 'archive-file 'RCS-archive-file)
  1110.  
  1111. (defun RCS-file-out-p (file)
  1112.   (save-window-excursion
  1113.     (let ((file-directory (directory-file-name (file-name-directory file)))
  1114.       (file-only (file-name-nondirectory file))
  1115.       (buffer "outness buffer for config"))
  1116.       (pop-to-buffer buffer)
  1117.       (erase-buffer)
  1118.       (insert file ?\n)
  1119.       (shell-command (concat "cd " file-directory " ;rlog -L -R " file-only) t)
  1120.       (cond ((= (length (buffer-string)) 0)
  1121.          (kill-buffer buffer)
  1122.          nil)
  1123.         ((progn (beginning-of-buffer)
  1124.             (search-forward "rlog error"
  1125.                     (point-max) t))
  1126.          (kill-buffer buffer)
  1127.          nil)
  1128.         ((progn (beginning-of-buffer)
  1129.             (search-forward (concat "RCS/" file-only ",v")
  1130.                     (point-max) t))
  1131.          (kill-buffer buffer)
  1132.          t)
  1133.         (t
  1134.          ;; Probably archive file doesn't exist.  Return nil, but
  1135.          ;; leave the buffer lying around.
  1136.          nil)))))
  1137.  
  1138.  
  1139. (cu-add 'RCS 'file-out-p 'RCS-file-out-p)
  1140.  
  1141. (defun RCS-out-list (dir)
  1142.   (let* ((dir (file-name-as-directory dir))
  1143.      (command (concat "cd " dir "RCS\nrlog -L -R *,v"))
  1144.      (list nil))
  1145.     (with-buffer " *config show out buffer*"
  1146.       (erase-buffer)
  1147.       (let ((shell-file-name *config-shell*))
  1148.     (shell-command command t))
  1149.       (beginning-of-buffer)
  1150.       (while (re-search-forward "^\\(.*\\),v$" nil t)
  1151.     (push (cu-make-full-path dir
  1152.                  (buffer-substring (match-beginning 1) 
  1153.                            (match-end 1)))
  1154.           list))
  1155.       (cond ((null list)
  1156.          nil)
  1157.         ((not (file-exists-p (car list)))
  1158.          nil)                ; Must be an error message
  1159.         (t
  1160.          (nreverse list))))))
  1161.  
  1162. (cu-add 'RCS 'out-list 'RCS-out-list)
  1163.  
  1164. (defun RCS-undo-out-command (file)
  1165.   (let ((file-directory (directory-file-name (file-name-directory file)))
  1166.     (file-only (file-name-nondirectory file)))
  1167.     (concat "cd " file-directory ";"
  1168.         "/bin/rm -f " file-only ";"
  1169.         "rcs -u " file-only ";"
  1170.         "co " file-only)))
  1171. (cu-add 'RCS 'undo-out-command 'RCS-undo-out-command)
  1172.  
  1173. (defun RCS-diff-command (file)
  1174.   (let ((file-directory (directory-file-name (file-name-directory file)))
  1175.     (file-only (file-name-nondirectory file)))
  1176.     (concat "cd " file-directory ";"
  1177.             "rcsdiff " file-only)))
  1178. (cu-add 'RCS 'diff-command 'RCS-diff-command)
  1179.  
  1180. (cu-add 'RCS 'checkout-newfile 'cu-checkout-newfile)
  1181. (cu-add 'RCS 'pop-to-changed-file 'cu-pop-to-changed-file)
  1182. (cu-add 'RCS 'massage-comment 'cu-massage-comment)
  1183. (cu-add 'RCS 'assert-good-filename 'cu-assert-good-filename)
  1184.  
  1185. (cu-add 'RCS 'sample-executable "rcs")
  1186.  
  1187. ;   ===%%SF%% generics/RCS (End)  ===
  1188.  
  1189. ;===%%SF%% generics (End)  ===
  1190.  
  1191.  
  1192. ;===%%SF%% util (Start)  ===
  1193.  
  1194. ;   ===%%SF%% util/checkin (Start)  ===
  1195. (defvar cu-checkin-mode-map nil)
  1196. (if cu-checkin-mode-map
  1197.     nil
  1198.   (setq cu-checkin-mode-map (make-sparse-keymap))
  1199.   (define-key cu-checkin-mode-map "\C-c\C-c" 'config-finish-checkin))
  1200.  
  1201. (defun cu-checkin-mode ()
  1202.   "Like text mode, except for one command:
  1203.  
  1204. C-c C-c  config-finish-checkin
  1205. "
  1206.   (kill-all-local-variables)
  1207.   (set-syntax-table text-mode-syntax-table)
  1208.   (use-local-map cu-checkin-mode-map)
  1209.   (setq local-abbrev-table text-mode-abbrev-table)
  1210.   (setq major-mode 'cu-checkin-mode)
  1211.   (setq mode-name "Checkin")
  1212.   (run-hooks 'text-mode-hook 'cu-checkin-mode-hook))
  1213.  
  1214.  
  1215. ;;; This does the actual work of the checkin.
  1216. ;;; After finished, the results buffer is in one window.  The cursor
  1217. ;;; is not in that window.  The file (if it was being edited) is in
  1218. ;;; the other window.
  1219. ;;; 
  1220. ;;; It's kludgy that you have to do the massaging within a buffer, but
  1221. ;;; there's so much more that works in a buffer -- regexp-replaces,
  1222. ;;; for example.
  1223. (defun cu-do-checkin (file comment)
  1224.   (cu-prepare-results-buffer file)
  1225.   (let ((massage-buffer (get-buffer-create " Massage buffer")))
  1226.     (with-buffer massage-buffer
  1227.        (erase-buffer)
  1228.        (insert comment)
  1229.        (funcall (cu-get 'massage-comment))
  1230.        (setq comment (buffer-string)))
  1231.     (kill-buffer massage-buffer))
  1232.   (config-shell-command (funcall (cu-get 'checkin-command) file comment))
  1233.   (if (get-file-buffer file)
  1234.       (progn
  1235.     (funcall (cu-get 'pop-to-changed-file) file)
  1236.     (setq buffer-read-only t)))
  1237.   (display-buffer *config-results-bufname*))
  1238.  
  1239. ;; This is called when the user types ^C^C in checkin-mode.
  1240. ;; Comment buffer goes away.  The results buffer is displayed.
  1241. ;; The cursor is not in that buffer.  If the file was in a buffer, that buffer
  1242. ;; must be visible in one window, with the cursor in it.  
  1243. (defun config-finish-checkin ()
  1244.   (interactive)
  1245.   (cu-assert-system-available)
  1246.   (let ((file checkin-file))    ; restore stashed filename.
  1247.     (beginning-of-buffer)
  1248.     (search-forward *config-header-delim*)
  1249.     (next-line 1)
  1250.     (beginning-of-line)
  1251.     (kill-region (point-min) (point))
  1252.     (let ((comment (buffer-string)))
  1253.       (set-register *config-comment-register* comment)
  1254.       (cu-do-checkin file (buffer-string)))
  1255.     (kill-buffer *config-comment-bufname*)
  1256.     (if *config-recursing*
  1257.     (exit-recursive-edit))))
  1258.  
  1259.  
  1260.  
  1261.   
  1262. ;;; You're checking in if the config comment buffer is modified.
  1263. ;;; It's okay to create the buffer; we assume it's about to be
  1264. ;;; used anyway.
  1265. (defun config-checking-in-p ()
  1266.   (buffer-modified-p (get-buffer-create *config-comment-bufname*)))
  1267.   
  1268. ;   ===%%SF%% util/checkin (End)  ===
  1269.  
  1270. ;   ===%%SF%% util/group-checkin (Start)  ===
  1271.  
  1272. (defun cu-list-in (list) 
  1273.   "This routine is passed a list of files to check in.  A 'Do you want
  1274. to reuse the last log message' question is asked for every checkin but
  1275. the first.  Results of checkins will go into a cumulative results
  1276. buffer, which will be displayed at the end of the routine."
  1277.   
  1278.   (if (null list)            ; Filters may have emptied list.
  1279.       (message "No files to check in.")
  1280.     (set-register *config-comment-register* nil)
  1281.     (let ((*config-recursing* t))
  1282.       (catch 'list-checkin-tag        ; See CONFIG-KILL-CHECKIN
  1283.     (dolist (file list)
  1284.       (if (and (config-archive-p file)
  1285.            (not (config-out-p file)))
  1286.           (cu-results-message "==> %s is not checked out for editing" file)
  1287.         (save-excursion (config-in file)))
  1288.       ;; Bury the buffer -- else the display can be confusing.
  1289.       (bury-buffer *config-results-bufname*)))
  1290.       (switch-to-buffer *config-results-bufname*)
  1291.       (delete-other-windows)
  1292.       (message "List checkin done."))))
  1293.  
  1294.  
  1295. ;; Duplicate checkin handling:
  1296. ;; There are two potential problems -- the config comment buffer is
  1297. ;; up for editing or another recursive checkin is in progress (in
  1298. ;; which case, the first is probably also true).  In both cases, you
  1299. ;; probably want to know right away (not when you finally get to
  1300. ;; checking in a file), so the tests should be made here instead of
  1301. ;; waiting for a test in config-in to catch things.
  1302. ;;
  1303. ;; Once tested, how to handle?  Could ask y/n questions and kill
  1304. ;; buffers and abort recursive edits.  I tried it.  It's too
  1305. ;; complicated.  We just tell her the problem and let her fix it --
  1306. ;; she's much more likely to do the right thing.
  1307. (defun cu-duplicate-checkin-p ()
  1308.   (if (or (config-checking-in-p)
  1309.       *config-recursing*)
  1310.       (let ((buf " Config Temp "))
  1311.     (pop-to-buffer buf)
  1312.     (momentary-string-display
  1313.      "You are in the middle of a checkin.  You must finish it or
  1314. abort it before starting this group checkin.  You can kill the checkin
  1315. with CONFIG-KILL-CHECKIN."
  1316.      (point))
  1317.     (kill-buffer buf)
  1318.     t)
  1319.     nil))
  1320.  
  1321. ;      ===%%SF%% util/group-checkin/filters (Start)  ===
  1322. ;;;
  1323. ;;; General note on filters:
  1324. ;;;   It's often a good idea to put a note about what files you
  1325. ;;;   filtered out in the results buffer, which tends to pop up at
  1326. ;;;   informative times. 
  1327.  
  1328. (defun cu-apply-file-filters (filelist)
  1329.   "Apply all the filters in *CONFIG-FILENAME-FILTER-LIST* to the
  1330. FILELIST and return the result."
  1331.   (dolist (filter *config-filename-filter-list*)
  1332.     (setq filelist (funcall filter filelist)))
  1333.   filelist)
  1334.          
  1335.  
  1336.  
  1337. (defun cu-standard-filter (inlist)
  1338.    "This routine returns a filtered version of INLIST.  The following
  1339. files are always removed from the list:
  1340. - Directories.
  1341. - Backup and auto-save files.
  1342. - C object files (ending in .o)
  1343. - Library files (ending in .a)
  1344. - Compressed files (ending in .Z or .z)
  1345. - Compiled elisp files (ending in .elc)
  1346. - Files with archive files that are not checked out for editing.
  1347.  
  1348. Exception:  If the file indeed has an archive file, and is checked
  1349. out for editing, it will be checked in regardless of its name.
  1350.  
  1351. If the file has an archive file, and is checked out for editing, it
  1352. will be checked in regardless of name.
  1353.  
  1354. This function is typically the value of *config-filename-filter-list*"
  1355.    (let ((outlist nil))
  1356.      (dolist (file inlist)
  1357.        (let ((file-only (file-name-nondirectory file))
  1358.          (file-out-p (config-out-p file)))    ; Save redundant
  1359.                             ; expensive check. 
  1360.      (cond (file-out-p
  1361.         (push file outlist))
  1362.            ((file-directory-p file)
  1363.         (cu-results-message "Not checking in %s -- it's a directory." file-only))
  1364.            ((backup-file-name-p file)
  1365.         (cu-results-message "Not checking in %s -- it's a backup file." file-only))
  1366.            ((auto-save-file-name-p file-only)
  1367.         (cu-results-message "Not checking in %s -- it's a checkpoint file." file-only))
  1368.            ((cu-c-object-file-name-p file)
  1369.         (cu-results-message "Not checking in %s -- it's an object file." file-only))
  1370.            ((cu-elisp-object-file-name-p file)
  1371.         (cu-results-message "Not checking in %s -- it's an object file." file-only))
  1372.            ((cu-compressed-file-name-p file)
  1373.         (cu-results-message "Not checking in %s -- it's a compressed file." file-only))
  1374.            ((cu-library-file-name-p file)
  1375.         (cu-results-message "Not checking in %s -- it's a library file." file-only))
  1376.            ((and (config-archive-p file)
  1377.              (not file-out-p))
  1378.         (cu-results-message "Not checking in %s -- it's not checked out." file-only))
  1379.            (t
  1380.          (push file outlist)))))
  1381.      (nreverse outlist)))
  1382.  
  1383. (defun cu-c-object-file-name-p (file)
  1384.   "Return non-nil if FILE is an object file name (*.o)"
  1385.   (string-match "\\.o$" file))
  1386.  
  1387. (defun cu-elisp-object-file-name-p (file)
  1388.   "Return non-nil if FILE is an object file name (*.elc)"
  1389.   (string-match "\\.elc$" file))
  1390.  
  1391. (defun cu-library-file-name-p (file)
  1392.   "Return non-nil if FILE is a library file name (*.a)"
  1393.   (string-match "\\.a$" file))
  1394.  
  1395. (defun cu-compressed-file-name-p (file)
  1396.   "Return non-nil if FILE is the name of a compressed file (*.[Zz])"
  1397.   (string-match "\\.[Zz]$" file))
  1398.  
  1399.  
  1400. (defun cu-query-filter (filelist)
  1401.   "This filter asks the user whether to check in a list of files."
  1402.   (when filelist
  1403.     (let ((buffer (get-buffer-create " *Checkin Query*")))
  1404.       (set-buffer buffer)
  1405.       (erase-buffer)
  1406.       (insert "Files to be checked in:\n")
  1407.       (insert "-----------------------\n")
  1408.       (cu-filelist-in-buffer filelist buffer)
  1409.       ;; Kludge -- we assume something interesting to see may also be in
  1410.       ;; the results buffer.
  1411.       (cu-display-two-buffers *config-results-bufname* buffer)
  1412.       (prog1
  1413.       (if (yes-or-no-p "Check in these files? ")
  1414.           filelist
  1415.         nil)
  1416.     (kill-buffer buffer)))))
  1417.  
  1418.          
  1419.  
  1420. (defun cu-outness-filter (inlist)
  1421.    "This routine returns a filtered version of INLIST.  Files that
  1422. are not checked out are removed from the list."
  1423.    (let ((outlist nil))
  1424.      (dolist (file inlist)
  1425.        (if (config-out-p file)
  1426.        (push file outlist)))
  1427.      (nreverse outlist)))
  1428.  
  1429. ;      ===%%SF%% util/group-checkin/filters (End)  ===
  1430.  
  1431. ;   ===%%SF%% util/group-checkin (End)  ===
  1432.  
  1433. ;   ===%%SF%% util/results (Start)  ===  Results buffer manipulation
  1434.  
  1435. ;;; Get the config-results buffer ready for a command.
  1436. ;;; Normally, the buffer is cleared.  When config is recursing (for a
  1437. ;;; group checkin, for example), it's not.
  1438. (defun cu-prepare-results-buffer (header)
  1439.   (cu-set-buffer-create *config-results-bufname*)
  1440.   (if (not *config-recursing*)
  1441.       (erase-buffer))
  1442.   (end-of-buffer)
  1443.   (insert header ?\n))
  1444.  
  1445. (defun cu-results-message (&rest args)
  1446.   "Print the message to both the minibuffer and the results buffer.
  1447. Pause to give the user a chance to read message."
  1448.   (apply 'message args)
  1449.   (sleep-for *config-sleep*)
  1450.   (apply 'cu-results-logit args))
  1451.  
  1452. (defun cu-results-logit (&rest args)
  1453.   "Print the message to the end of the results buffer, suffixing with newline."
  1454.   (save-window-excursion
  1455.     (switch-to-buffer *config-results-bufname*)
  1456.     (end-of-buffer)
  1457.     (insert (apply 'format args) "\n")))
  1458.  
  1459. ;   ===%%SF%% util/results (End)  ===
  1460.  
  1461. ;   ===%%SF%% util/systems (Start)  === ; Do they exist?
  1462.  
  1463. ;;; Make a pathname from a directory and a filename.  UNIX-specific.
  1464. (defun cu-make-full-path (directory filename)
  1465.   (if (null directory)
  1466.       filename
  1467.     (concat (file-name-as-directory directory) filename)))
  1468.  
  1469. ;;; Return the pathname if a file exists in the path; otherwise,
  1470. ;;; return NIL.
  1471. (defun cu-file-exists-in-path-p (filename path)
  1472.     (cond ((null path)
  1473.        nil)
  1474.       ((file-exists-p (cu-make-full-path (car path) filename)))
  1475.       ((cu-file-exists-in-path-p filename (cdr path)))))
  1476.  
  1477. (defvar cu-saved-config-type nil
  1478.   "Stashed value of *config-type*  -- avoids repeated checking.")
  1479.  
  1480. (defvar cu-system-checks-out nil
  1481.   "System has been checked -- it was available.")
  1482.  
  1483. (defun cu-assert-system-available ()
  1484.   "Call this routine at the beginning of every interactive function.
  1485. It checks whether the *config-type* system is in the EXEC-PATH.  This
  1486. minimizes the chance of botched operations."
  1487.   ;; The check is made only if the config-type has changed or it's
  1488.   ;; never yet been made. 
  1489.   (when (or (not (eq cu-saved-config-type *config-type*))
  1490.         (not cu-system-checks-out))
  1491.     (setq cu-saved-config-type *config-type*)
  1492.     (setq cu-system-checks-out nil)
  1493.     (let ((executable (cu-get 'sample-executable)))
  1494.       (if (cu-file-exists-in-path-p executable exec-path)
  1495.           (setq cu-system-checks-out t)
  1496.         (error "No executable %s -- does %s exist on this system?"
  1497.            executable (symbol-name *config-type*))))))
  1498.                         
  1499. ;   ===%%SF%% util/systems (End)  ===    
  1500.  
  1501. ;   ===%%SF%% util/misc (Start)  ===
  1502.  
  1503. ;;; Strips .<foo> from name.  (Note -- (cu-file-basename "foo.bar.baz") ==> "foo")
  1504. ;;; Note:  simplified by fact that (substring "foo" 0 NIL) ==> "foo").
  1505. (defun cu-file-basename (name)
  1506.   (substring name 0 (string-match "\\." name)))
  1507.  
  1508.  
  1509. ;;; Execute command, results in current buffer.  If
  1510. ;;; *config-verbose-commands*, also put the command in the buffer.
  1511. (defun config-shell-command (command)
  1512.   (end-of-buffer)
  1513.   (if *config-verbose-commands*
  1514.       (insert "Command is:\n" command "\nResults are:\n"))
  1515.   (let ((shell-file-name *config-shell*))
  1516.     (shell-command command t)))
  1517.  
  1518.  
  1519. (defun cu-expand-and-check (file &optional no-dir missing-ok)
  1520.   "This function expands and substitutes the filename.  It also
  1521. signals an error if the file doesn't really exist (unless MISSING-OK
  1522. is non-NIL).  If the optional NO-DIR argument is non-nil, it will
  1523. complain if the FILE is really a directory."
  1524.   (if (and (not (file-exists-p file))
  1525.        (not missing-ok))
  1526.       (error "File %s doesn't exist." file))
  1527.   (if (and no-dir
  1528.        (file-directory-p file))
  1529.       (error "%s is a directory." file))
  1530.   (expand-file-name (substitute-in-file-name file)))
  1531.  
  1532. ;;; If editing the file, save it.
  1533. (defun cu-maybe-save-file (file)
  1534.   (let ((file-buffer (get-file-buffer file)))
  1535.     (if file-buffer
  1536.     (save-window-excursion
  1537.       (switch-to-buffer file-buffer)
  1538.       (basic-save-buffer)))))
  1539.  
  1540. ;; Like set-buffer, but doesn't error out if the buffer doesn't exist.
  1541. (defun cu-set-buffer-create (bufname)
  1542.   (let ((buf (get-buffer-create bufname)))
  1543.     (set-buffer buf)))
  1544.  
  1545. (defun cu-display-two-buffers (current other)
  1546.   "Make sure these two buffers are displayed.  CURRENT becomes the
  1547. current buffer."
  1548.   (switch-to-buffer current)
  1549.   (delete-other-windows)
  1550.   (display-buffer other))
  1551.  
  1552. (defun cu-filelist-in-buffer (filelist buffer)
  1553.   "Format the given FILELIST into the given BUFFER.  There's no change
  1554. in the display.  Only the non-directory parts of the filenames are shown."
  1555.   (with-buffer buffer
  1556.     (setq fill-column 70)
  1557.     (dolist (file (mapcar 'file-name-nondirectory filelist))
  1558.       (if (> (current-column) 59)
  1559.       (insert ?\n)
  1560.     (or (= (current-column) 0)
  1561.         (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
  1562.       (insert file))
  1563.     (goto-char (point-min))))
  1564.  
  1565.  
  1566. ;   ===%%SF%% util/misc (End)  ===
  1567.  
  1568. ;===%%SF%% util (End)  ===
  1569.  
  1570.  
  1571.  
  1572.  
  1573.  
  1574.  
  1575.