/[cmucl]/src/hemlock/rcs.lisp
ViewVC logotype

Diff of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by wlott, Fri Feb 9 21:20:32 1990 UTC revision 1.6 by ch, Fri Mar 2 20:45:44 1990 UTC
# Line 1  Line 1 
1  ;;; -*- Package: HEMLOCK -*-  ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2  ;;;  ;;;
3  ;;; $Header$  ;;; $Header$
4  ;;;  ;;;
# Line 7  Line 7 
7    
8  (in-package "HEMLOCK")  (in-package "HEMLOCK")
9    
10    
11    ;;;;
12    
13    (defhvar "RCS Check Out Keep Original As Backup"
14      "If non-NIL, all comamnds which perform an RCS check out will rename
15      any existing original file to a backup filename."
16      :value nil)
17    
18  (defun current-buffer-pathname ()  (defun current-buffer-pathname ()
19    (let ((pathname (buffer-pathname (current-buffer))))    (let ((pathname (buffer-pathname (current-buffer))))
# Line 71  Line 78 
78    (in-directory pathname    (in-directory pathname
79      (let ((file (file-namestring pathname)))      (let ((file (file-namestring pathname)))
80        (do-command "rcs" `("-l" ,file))        (do-command "rcs" `("-l" ,file))
81        (multiple-value-bind        (multiple-value-bind (won dev ino mode) (mach:unix-stat file)
82            (won dev ino mode)          (declare (ignore ino))
83            (mach:unix-stat file)          (cond (won
84          (declare (ignore dev ino))                 (mach:unix-chmod file (logior mode mach:writeown)))
85          (when won                (t
86            (mach:unix-chmod file (logior mode mach:writeown)))))))                 (editor-error "MACH:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
87                                 (mach:get-unix-error-msg dev))))))))
88    
89  (defun rcs-unlock-file (pathname)  (defun rcs-unlock-file (pathname)
90    (message "Unlocking ~A ..." (namestring pathname))    (message "Unlocking ~A ..." (namestring pathname))
91    (in-directory pathname    (in-directory pathname
92      (do-command "rcs" `("-u" ,(file-namestring pathname)))))      (do-command "rcs" `("-u" ,(file-namestring pathname)))))
93    
94    
95    ;;;; Check In
96    
97  (defun rcs-check-in-file (pathname keep-lock)  (defun rcs-check-in-file (pathname keep-lock)
98    (let ((old-buffer (current-buffer))    (let ((old-buffer (current-buffer))
99          (allow-delete nil)          (allow-delete nil)
# Line 118  Line 129 
129        (setf allow-delete t)        (setf allow-delete t)
130        (delete-buffer buffer))))        (delete-buffer buffer))))
131    
132    
133    ;;;; Check Out
134    
135    (defun maybe-rcs-check-out-file (pathname lock always-overwrite-p)
136      (maybe-rcs-check-out-files (list pathname) lock always-overwrite-p))
137    
138    (defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
139      (let ((check-out-count 0))
140        (macrolet ((frob ()
141                     `(progn
142                        (rcs-check-out-file pathname lock)
143                        (incf check-out-count))))
144          (dolist (pathname pathnames)
145            (cond
146             ((and (not always-overwrite-p)
147                   (probe-file pathname) (ext:file-writable pathname))
148              ;; File exists and is writable so check and see if the user really
149              ;; wants to check it out.
150              (command-case (:prompt
151                             (format nil "The file ~A is writable.  Overwrite? "
152                                     (file-namestring pathname))
153                             :help
154                             "Type one of the following single-character commands:")
155                ((:yes :confirm)
156                 "Overwrite the file."
157                 (frob))
158                (:no
159                 "Skip checking out this file.")
160                ((#\r #\R)
161                 "Rename the file before checking it out."
162                 (let ((new-pathname (prompt-for-file
163                                      :prompt "New Filename: "
164                                      :default (buffer-default-pathname
165                                                  (current-buffer))
166                                      :must-exist nil)))
167                   (rename-file pathname new-pathname)
168                   (frob)))
169                (:do-all
170                 "Overwrite this file and all remaining files."
171                 (setf always-overwrite-p t)
172                 (frob))
173                (:do-once
174                 "Overwrite this file and then exit."
175                 (frob)
176                 (return))
177                (:exit
178                 "Exit immediately."
179                 (return))))
180             (t
181              (frob)))))
182        check-out-count))
183    
184  (defun rcs-check-out-file (pathname lock)  (defun rcs-check-out-file (pathname lock)
185    (message "Checking out ~A ..." (namestring pathname))    (message "Checking out ~A ..." (namestring pathname))
186    (in-directory pathname    (in-directory pathname
# Line 125  Line 188 
188             (if (probe-file pathname)             (if (probe-file pathname)
189                 (lisp::pick-backup-name (namestring pathname))                 (lisp::pick-backup-name (namestring pathname))
190                 nil)))                 nil)))
191        (when backup        (when backup (rename-file pathname backup))
         (rename-file pathname backup))  
192        (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))        (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
193        (when backup        (unless (value rcs-check-out-keep-original-as-backup)
194          (delete-file backup)))))          (delete-file backup)))))
195    
   
   
196  (defun pick-temp-file (defaults)  (defun pick-temp-file (defaults)
197    (let ((index 0))    (let ((index 0))
198      (loop      (loop
# Line 142  Line 202 
202                (t                (t
203                 (return name)))))))                 (return name)))))))
204    
205    
206    ;;;; Checking In / Checking Out and Locking / Unlocking
207    
208  (defcommand "RCS Lock Buffer File" (p)  (defcommand "RCS Lock Buffer File" (p)
209    "Attempt to lock the file in the current buffer."    "Attempt to lock the file in the current buffer."
210    "Attempt to lock the file in the current buffer."    "Attempt to lock the file in the current buffer."
# Line 190  Line 253 
253                                      :must-exist nil)))                                      :must-exist nil)))
254    
255  (defcommand "RCS Check In Buffer File" (p)  (defcommand "RCS Check In Buffer File" (p)
256    "Checkin the file in the current buffer.  With an argument, do not release    "Checkin the file in the current buffer.  With an argument, do not
257    the lock."    release the lock."
258    "Checkin the file in the current buffer.  With an argument, do not release    "Checkin the file in the current buffer.  With an argument, do not
259    the lock."    release the lock."
260    (let ((buffer (current-buffer))    (let ((buffer (current-buffer))
261          (pathname (current-buffer-pathname)))          (pathname (current-buffer-pathname)))
262      (when (buffer-modified buffer)      (when (buffer-modified buffer)
# Line 202  Line 265 
265      (visit-file-command nil pathname buffer)))      (visit-file-command nil pathname buffer)))
266    
267  (defcommand "RCS Check In File" (p)  (defcommand "RCS Check In File" (p)
268    "Prompt for a file, and attempt to check it in.  With an argument, do not    "Prompt for a file, and attempt to check it in.  With an argument, do
269    release the lock."    not release the lock."
270    "Prompt for a file, and attempt to check it in.  With an argument, do not    "Prompt for a file, and attempt to check it in.  With an argument, do
271    release the lock."    not release the lock."
272    (rcs-check-in-file (prompt-for-file :prompt "File to lock: "    (rcs-check-in-file (prompt-for-file :prompt "File to lock: "
273                                        :default                                        :default
274                                           (buffer-default-pathname                                           (buffer-default-pathname
# Line 214  Line 277 
277                       p))                       p))
278    
279  (defcommand "RCS Check Out Buffer File" (p)  (defcommand "RCS Check Out Buffer File" (p)
280    "Checkout the file in the current buffer.  With an argument, lock the file."    "Checkout the file in the current buffer.  With an argument, lock the
281    "Checkout the file in the current buffer.  With an argument, lock the file."    file."
282      "Checkout the file in the current buffer.  With an argument, lock the
283      file."
284    (let* ((buffer (current-buffer))    (let* ((buffer (current-buffer))
285           (pathname (current-buffer-pathname))           (pathname (current-buffer-pathname))
286           (point (current-point))           (point (current-point))
# Line 223  Line 288 
288      (when (buffer-modified buffer)      (when (buffer-modified buffer)
289        (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))        (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
290          (editor-error "Aborted.")))          (editor-error "Aborted.")))
291      (rcs-check-out-file pathname p)      (maybe-rcs-check-out-file pathname p nil)
292      (setf (buffer-modified buffer) nil)      (setf (buffer-modified buffer) nil)
293      (when p      (when p
294        (setf (buffer-writable buffer) t)        (setf (buffer-writable buffer) t)
# Line 233  Line 298 
298        (buffer-end point))))        (buffer-end point))))
299    
300  (defcommand "RCS Check Out File" (p)  (defcommand "RCS Check Out File" (p)
301    "Prompt for a file and attempt to check it out.  With an argument, lock the    "Prompt for a file and attempt to check it out.  With an argument,
302    file."    lock the file."
303    "Prompt for a file and attempt to check it out.  With an argument, lock the    "Prompt for a file and attempt to check it out.  With an argument,
304    file."    lock the file."
305    (let ((pathname (prompt-for-file :prompt "File to check out: "    (let ((pathname (prompt-for-file :prompt "File to check out: "
306                                     :default (buffer-default-pathname                                     :default (buffer-default-pathname
307                                               (current-buffer))                                               (current-buffer))
308                                     :must-exist nil)))                                     :must-exist nil)))
309      (rcs-check-out-file pathname p)      (maybe-rcs-check-out-file pathname p nil)
310      (find-file-command nil pathname)))      (find-file-command nil pathname)))
311    
312    
313    ;;;; Log File
314    
315  (defhvar "RCS Log Entry Buffer"  (defhvar "RCS Log Entry Buffer"
316    "Name of the buffer to put RCS log entries into."    "Name of the buffer to put RCS log entries into."
317    :value "RCS Log")    :value "RCS Log")
# Line 290  Line 358 
358      (buffer-start (current-point))      (buffer-start (current-point))
359      (setf (buffer-modified buffer) nil)))      (setf (buffer-modified buffer) nil)))
360    
361    
362    ;;;; Directory Support
363    
364  (defcommand "RCS Update Directory" (p)  (defun list-out-of-date-files (dir)
365    "Prompt for a directory and check out all files that are older than the    (let ((rcsdir (make-pathname :host (pathname-host dir)
366    corresponding RCS file.  With an argument, never ask about overwriting                                 :device (pathname-device dir)
367    writable files."                                 :directory (concatenate 'simple-vector
368    "Prompt for a directory and check out all files that are older than the                                                         (pathname-directory dir)
369    corresponding RCS file.  With an argument, never ask about overwriting                                                         (vector "RCS"))))
370    writable files."          (out-of-date-files nil))
371    (let* ((def (buffer-default-pathname (current-buffer)))      (unless (directoryp rcsdir)
372           (dir (prompt-for-file :prompt "Directory to update: "        (editor-error "Could not find the RCS directory."))
373        (dolist (rcsfile (directory rcsdir))
374          (let ((rcsname (file-namestring rcsfile)))
375            (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
376              (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
377                     (file (merge-pathnames (parse-namestring name) dir)))
378                (unless (and (probe-file file)
379                             (>= (file-write-date file) (file-write-date rcsfile)))
380                  (push file out-of-date-files))))))
381        out-of-date-files))
382    
383    (defun rcs-prompt-for-directory (prompt)
384      (let* ((default (buffer-default-pathname (current-buffer)))
385             (dir (prompt-for-file :prompt prompt
386                                 :default (make-pathname                                 :default (make-pathname
387                                           :host (pathname-host def)                                           :host (pathname-host default)
388                                           :device (pathname-device def)                                           :device (pathname-device default)
389                                           :directory (pathname-directory def)                                           :directory (pathname-directory default)
390                                           :defaults nil)                                           :defaults nil)
391                                 :must-exist nil)))                                 :must-exist nil)))
392      (unless (directoryp dir)      (unless (directoryp dir)
# Line 313  Line 396 
396          (unless (directoryp with-slash)          (unless (directoryp with-slash)
397            (editor-error "~S is not a directory" (namestring dir)))            (editor-error "~S is not a directory" (namestring dir)))
398          (setf dir with-slash)))          (setf dir with-slash)))
399      (let ((rcsdir      dir))
400             (make-pathname :host (pathname-host dir)  
401                            :device (pathname-device dir)  (defcommand "RCS Update Directory" (p)
402                            :directory (concatenate 'simple-vector    "Prompt for a directory and check out all files that are older than
403                                                    (pathname-directory dir)    their corresponding RCS files.  With an argument, never ask about
404                                                    (vector "RCS"))))    overwriting writable files."
405            (count 0))    "Prompt for a directory and check out all files that are older than
406        (unless (directoryp rcsdir)    the corresponding RCS file.  With an argument, never ask about
407          (editor-error "Could not find the RCS directory."))    overwriting writable files."
408        (dolist (rcsfile (directory rcsdir))    (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
409          (let ((rcsname (file-namestring rcsfile)))           (out-of-date-files (list-out-of-date-files directory))
410            (when (string= rcsname ",v" :start1 (- (length rcsname) 2))           (n-out-of-date (length out-of-date-files)))
411              (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))      (cond ((zerop n-out-of-date)
412                     (file (merge-pathnames (parse-namestring name)             (message "All RCS files in ~A are up to date."
413                                            dir)))                      (namestring directory)))
414                (when (and (probe-file file)            (t
415                           (< (file-write-date file) (file-write-date rcsfile)))             (let ((n-checked-out
416                  (multiple-value-bind                    (maybe-rcs-check-out-files out-of-date-files nil p)))
417                      (won dev inode mode)               (message "Number of files out of date: ~D; ~
418                      (mach:unix-stat (namestring file))               number of files checked out: ~D"
419                    (declare (ignore dev inode))                        n-out-of-date n-checked-out)))))))
420                    (when (and won (not (zerop (logand mode mach:writeown))))  
421                      (cond ((or p  (defcommand "RCS List Out Of Date Files" (p)
422                                 (not (prompt-for-y-or-n    "Prompt for a directory and list all of the files that are older than
423                                       :prompt    their corresponding RCS files."
424                                       (format nil    "Prompt for a directory and list all of the files that are older than
425                                               "~S is writable, overwrite? "    their corresponding RCS files."
426                                               (namestring file))    (declare (ignore p))
427                                       :default nil    (let* ((directory (rcs-prompt-for-directory "Directory: "))
428                                       :default-string "n")))           (out-of-date-files (list-out-of-date-files directory)))
429                             (let ((private      (cond ((null out-of-date-files)
430                                    (merge-pathnames (concatenate             (message "All RCS files in ~A are up to date."
431                                                      'simple-string                      (namestring directory)))
432                                                      (file-namestring file)            (t
433                                                      ".private")             (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
434                                                     file)))               (format s "Directory: ~A~%~%" (namestring directory))
435                               (message "Renaming ~S to ~S"               (dolist (file out-of-date-files)
436                                        (namestring file)                 (format s "~A~%" (file-namestring file))))))))
                                       (namestring private))  
                              (rename-file file private)))  
                           (t  
                            (delete-file file))))  
                   (incf count)  
                   (rcs-check-out-file file nil)))))))  
       (if (zerop count)  
           (message "No files are out of date.")  
           (message "Checked out ~D file~:P" count)))))  

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5