diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp index 9ea7644d056d4e70aeb8bb7289c9c87d095d716b..fd74a539d78badb9851d0d24685edfb0907905a6 100644 --- a/hemlock/rcs.lisp +++ b/hemlock/rcs.lisp @@ -1,6 +1,6 @@ ;;; -*- Package: HEMLOCK -*- ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.2 1990/02/06 17:48:25 ch Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.3 1990/02/09 19:10:08 wlott Exp $ ;;; ;;; Various commands for dealing with RCS under hemlock. ;;; @@ -108,7 +108,6 @@ (message "Checking in ~A ..." (namestring pathname)) (in-directory pathname (do-command "rcsci" `(,@(if keep-lock '("-l")) - "-U" ,(file-namestring pathname)) :input (make-hemlock-region-stream (buffer-region buffer)))) @@ -121,10 +120,15 @@ (defun rcs-check-out-file (pathname lock) (message "Checking out ~A ..." (namestring pathname)) (in-directory pathname - (let ((backup (lisp::pick-backup-name (namestring pathname)))) - (rename-file pathname backup) + (let ((backup + (if (probe-file pathname) + (lisp::pick-backup-name (namestring pathname)) + nil))) + (when backup + (rename-file pathname backup)) (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname))) - (delete-file backup)))) + (when backup + (delete-file backup))))) @@ -284,3 +288,72 @@ (change-to-buffer buffer) (buffer-start (current-point)) (setf (buffer-modified buffer) nil))) + + +(defcommand "RCS Update Directory" (p) + "Prompt for a directory and check out all files that are older than the + corresponding RCS file. With an argument, never ask about overwriting + writable files." + "Prompt for a directory and check out all files that are older than the + corresponding RCS file. With an argument, never ask about overwriting + writable files." + (let* ((def (buffer-default-pathname (current-buffer))) + (dir (prompt-for-file :prompt "Directory to update: " + :default (make-pathname + :host (pathname-host def) + :device (pathname-device def) + :directory (pathname-directory def) + :defaults nil) + :must-exist nil))) + (unless (directoryp dir) + (let ((with-slash (parse-namestring (concatenate 'simple-string + (namestring dir) + "/")))) + (unless (directoryp with-slash) + (editor-error "~S is not a directory" (namestring dir))) + (setf dir with-slash))) + (let ((rcsdir + (make-pathname :host (pathname-host dir) + :device (pathname-device dir) + :directory (concatenate 'simple-vector + (pathname-directory dir) + (vector "RCS")))) + (did-any nil)) + (unless (directoryp rcsdir) + (editor-error "Could not find the RCS directory.")) + (dolist (rcsfile (directory rcsdir)) + (let ((rcsname (file-namestring rcsfile))) + (when (string= rcsname ",v" :start1 (- (length rcsname) 2)) + (let* ((name (subseq rcsname 0 (- (length rcsname) 2))) + (file (merge-pathnames (parse-namestring name) + dir))) + (when (< (file-write-date file) (file-write-date rcsfile)) + (multiple-value-bind + (won dev inode mode) + (mach:unix-stat (namestring file)) + (declare (ignore dev inode)) + (when (and won (not (zerop (logand mode mach:writeown)))) + (cond ((or p + (not (prompt-for-y-or-n + :prompt + (format nil + "~S is writable, overwrite? " + (namestring file)) + :default nil + :default-string "n"))) + (let ((private + (merge-pathnames (concatenate + 'simple-string + (file-namestring file) + ".private") + file))) + (message "Renaming ~S to ~S" + (namestring file) + (namestring private)) + (rename-file file private))) + (t + (delete-file file)))) + (setf did-any t) + (rcs-check-out-file file nil))))))) + (unless did-any + (message "No files are out of date.")))))