/[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.1 by wlott, Tue Feb 6 11:43:44 1990 UTC revision 1.2 by ch, Tue Feb 6 17:48:25 1990 UTC
# Line 59  Line 59 
59                  (string/= (line-string buffer-line) file-line))                  (string/= (line-string buffer-line) file-line))
60          (return t)))))          (return t)))))
61    
62    (defun turn-auto-save-off (buffer)
63      (setf (buffer-minor-mode buffer "Save") nil)
64      ;;
65      ;; William's personal hack
66      (when (getstring "Ckp" *mode-names*)
67        (setf (buffer-minor-mode buffer "Ckp") nil)))
68    
69  (defun rcs-lock-file (pathname)  (defun rcs-lock-file (pathname)
70    (message "Locking ~A" (namestring pathname))    (message "Locking ~A ..." (namestring pathname))
71    (in-directory pathname    (in-directory pathname
72      (let ((file (file-namestring pathname)))      (let ((file (file-namestring pathname)))
73        (do-command "rcs" `("-l" ,file))        (do-command "rcs" `("-l" ,file))
# Line 72  Line 79 
79            (mach:unix-chmod file (logior mode mach:writeown)))))))            (mach:unix-chmod file (logior mode mach:writeown)))))))
80    
81  (defun rcs-unlock-file (pathname)  (defun rcs-unlock-file (pathname)
82    (message "Unlocking ~A" (namestring pathname))    (message "Unlocking ~A ..." (namestring pathname))
83    (in-directory pathname    (in-directory pathname
84      (do-command "rcs" `("-u" ,(file-namestring pathname)))))      (do-command "rcs" `("-u" ,(file-namestring pathname)))))
85    
# Line 94  Line 101 
101                                                 (unless allow-delete                                                 (unless allow-delete
102                                                   (return-from in-recursive-edit                                                   (return-from in-recursive-edit
103                                                                t)))))))                                                                t)))))))
104                  (setf (buffer-minor-mode buffer "Save") nil)                  (turn-auto-save-off buffer)
                 (when (getstring "Ckp" *mode-names*)  
                   (setf (buffer-minor-mode buffer "Ckp") nil))  
105                  (change-to-buffer buffer)                  (change-to-buffer buffer)
106                  (do-recursive-edit)                  (do-recursive-edit)
107    
108                  (message "Checking in ~A" (namestring pathname))                  (message "Checking in ~A ..." (namestring pathname))
109                  (in-directory pathname                  (in-directory pathname
110                    (do-command "rcsci" `(,@(if keep-lock '("-l"))                    (do-command "rcsci" `(,@(if keep-lock '("-l"))
111                                          "-U"                                          "-U"
# Line 114  Line 119 
119        (delete-buffer buffer))))        (delete-buffer buffer))))
120    
121  (defun rcs-check-out-file (pathname lock)  (defun rcs-check-out-file (pathname lock)
122    (message "Checking out ~A" (namestring pathname))    (message "Checking out ~A ..." (namestring pathname))
123    (in-directory pathname    (in-directory pathname
124      (let ((backup (lisp::pick-backup-name (namestring pathname))))      (let ((backup (lisp::pick-backup-name (namestring pathname))))
125        (rename-file pathname backup)        (rename-file pathname backup)
# Line 147  Line 152 
152                          :output (namestring name)))                          :output (namestring name)))
153            (when (buffer-different-from-file buffer name)            (when (buffer-different-from-file buffer name)
154              (message              (message
155               "RCS file is different, be sure to merge your changes in."))               "RCS file is different: be sure to merge in your changes."))
156            (setf (buffer-writable buffer) t)            (setf (buffer-writable buffer) t)
157            (message "Buffer is now writable."))            (message "Buffer is now writable."))
158        (when (probe-file name)        (when (probe-file name)
# Line 158  Line 163 
163    "Prompt for a file, and attempt to lock it."    "Prompt for a file, and attempt to lock it."
164    (declare (ignore p))    (declare (ignore p))
165    (rcs-lock-file (prompt-for-file :prompt "File to lock: "    (rcs-lock-file (prompt-for-file :prompt "File to lock: "
166                                    :default (buffer-pathname (current-buffer))                                    :default (buffer-default-pathname
167                                                (current-buffer))
168                                    :must-exist nil)))                                    :must-exist nil)))
169    
170  (defcommand "RCS Unlock Buffer File" (p)  (defcommand "RCS Unlock Buffer File" (p)
# Line 174  Line 180 
180    "Prompt for a file, and attempt to unlock it."    "Prompt for a file, and attempt to unlock it."
181    (declare (ignore p))    (declare (ignore p))
182    (rcs-unlock-file (prompt-for-file :prompt "File to unlock: "    (rcs-unlock-file (prompt-for-file :prompt "File to unlock: "
183                                      :default (buffer-pathname (current-buffer))                                      :default (buffer-default-pathname
184                                                  (current-buffer))
185                                      :must-exist nil)))                                      :must-exist nil)))
186    
187  (defcommand "RCS Check In Buffer File" (p)  (defcommand "RCS Check In Buffer File" (p)
# Line 196  Line 203 
203    release the lock."    release the lock."
204    (rcs-check-in-file (prompt-for-file :prompt "File to lock: "    (rcs-check-in-file (prompt-for-file :prompt "File to lock: "
205                                        :default                                        :default
206                                           (buffer-pathname (current-buffer))                                           (buffer-default-pathname
207                                              (current-buffer))
208                                        :must-exist nil)                                        :must-exist nil)
209                       p))                       p))
210    
# Line 225  Line 233 
233    "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, lock the
234    file."    file."
235    (let ((pathname (prompt-for-file :prompt "File to check out: "    (let ((pathname (prompt-for-file :prompt "File to check out: "
236                                     :default (buffer-pathname (current-buffer))                                     :default (buffer-default-pathname
237                                                 (current-buffer))
238                                     :must-exist nil)))                                     :must-exist nil)))
239      (rcs-check-out-file pathname p)      (rcs-check-out-file pathname p)
240      (find-file-command nil pathname)))      (find-file-command nil pathname)))
# Line 238  Line 247 
247    (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))    (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
248      (unless buffer      (unless buffer
249        (setf buffer (make-buffer (value rcs-log-entry-buffer)))        (setf buffer (make-buffer (value rcs-log-entry-buffer)))
250        (setf (buffer-minor-mode buffer "Save") nil)        (turn-auto-save-off buffer))
       (when (getstring "Ckp" *mode-names*)  
         (setf (buffer-minor-mode buffer "Ckp") nil)))  
251      buffer))      buffer))
252    
253  (defcommand "RCS Buffer File Log Entry" (p)  (defcommand "RCS Buffer File Log Entry" (p)
# Line 250  Line 257 
257    (let ((buffer (get-log-buffer))    (let ((buffer (get-log-buffer))
258          (pathname (current-buffer-pathname)))          (pathname (current-buffer-pathname)))
259      (delete-region (buffer-region buffer))      (delete-region (buffer-region buffer))
260      (message "Extracing log info.")      (message "Extracting log info ...")
261      (with-mark ((mark (buffer-start-mark buffer) :left-inserting))      (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
262        (in-directory pathname        (in-directory pathname
263          (do-command "rlog" (list (file-namestring pathname))          (do-command "rlog" (list (file-namestring pathname))
# Line 260  Line 267 
267      (setf (buffer-modified buffer) nil)))      (setf (buffer-modified buffer) nil)))
268    
269  (defcommand "RCS File Log Entry" (p)  (defcommand "RCS File Log Entry" (p)
270    "Prompt for a file and get it's RCS log entry in a buffer."    "Prompt for a file and get its RCS log entry in a buffer."
271    "Prompt for a file and get it's RCS log entry in a buffer."    "Prompt for a file and get its RCS log entry in a buffer."
272    (declare (ignore p))    (declare (ignore p))
273    (let ((file (prompt-for-file :prompt "File to get log of: "    (let ((file (prompt-for-file :prompt "File to get log of: "
274                                 :default (buffer-pathname (current-buffer))                                 :default (buffer-default-pathname
275                                             (current-buffer))
276                                 :must-exist nil))                                 :must-exist nil))
277          (buffer (get-log-buffer)))          (buffer (get-log-buffer)))
278      (delete-region (buffer-region buffer))      (delete-region (buffer-region buffer))
279      (message "Extracing log info.")      (message "Extracing log info ...")
280      (with-mark ((mark (buffer-start-mark buffer) :left-inserting))      (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
281        (in-directory file        (in-directory file
282          (do-command "rlog" (list (file-namestring file))          (do-command "rlog" (list (file-namestring file))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5